refactor: App.hs and related changes (#1725)

* Use ExceptT to avoid 'staircasing' case analysis in App.hs
* Split large function in App.hs into individual handler functions
* Adapt API of Auth.hs, OpenApi.hs etc. to simplify the use of those modules in App.hs
* Split optional rollback functionality into Middleware
* Unify SimpleError and ApiRequestError into one Error type, so it can be used across modules

src/PostgREST/OpenAPI.hs

@@ -2,17 +2,15 @@
 Module      : PostgREST.OpenAPI
 Description : Generates the OpenAPI output
 -}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module PostgREST.OpenAPI (encode) where
 
-module PostgREST.OpenAPI (
-  encodeOpenAPI
-, pickProxy
-) where
-
-import qualified Data.HashSet.InsOrd as Set
+import qualified Data.Aeson           as JSON
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict  as HashMap
+import qualified Data.HashSet.InsOrd  as Set
 
 import Control.Arrow              ((&&&))
-import Data.Aeson                 (decode, encode)
 import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
 import Data.Maybe                 (fromJust)
 import Data.String                (IsString (..))
@@ -25,16 +23,29 @@ import Control.Lens
 import Data.Swagger
 
 import PostgREST.ApiRequest       (ContentType (..))
-import PostgREST.Config           (docsVersion, prettyVersion)
+import PostgREST.Config           (AppConfig (..), docsVersion,
+                                   prettyVersion)
 import PostgREST.Private.ProxyUri (isMalformedProxyUri, toURI)
-import PostgREST.Types            (Column (..), ForeignKey (..),
-                                   PgArg (..), PrimaryKey (..),
+import PostgREST.Types            (Column (..), DbStructure (..),
+                                   ForeignKey (..), PgArg (..),
+                                   PrimaryKey (..),
                                    ProcDescription (..), Proxy (..),
-                                   Table (..), toMime)
+                                   Table (..), tableCols, tableName,
+                                   tablePKCols, tableSchema, toMime)
 import Protolude                  hiding (Proxy, dropWhile, get,
                                    intercalate, toLower, toS, (&))
 import Protolude.Conv             (toS)
 
+encode :: AppConfig -> DbStructure -> [Table] -> Maybe Text -> HashMap.HashMap k [ProcDescription] -> LBS.ByteString
+encode conf dbStructure tables schemaDescription procs =
+  JSON.encode $
+    postgrestSpec
+      (concat $ HashMap.elems procs)
+      (openApiTableInfo dbStructure <$> tables)
+      (proxyUri conf)
+      schemaDescription
+      (dbPrimaryKeys dbStructure)
+
 makeMimeList :: [ContentType] -> MimeList
 makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
 
@@ -63,7 +74,7 @@ makeTableDef pks (t, cs, _) =
 makeProperty :: [PrimaryKey] -> Column -> (Text, Referenced Schema)
 makeProperty pks c = (colName c, Inline s)
   where
-    e = if null $ colEnum c then Nothing else decode $ encode $ colEnum c
+    e = if null $ colEnum c then Nothing else JSON.decode $ JSON.encode $ colEnum c
     fk ForeignKey{fkCol=Column{colTable=Table{tableName=a}, colName=b}} =
       intercalate "" ["This is a Foreign Key to `", a, ".", b, "`.<fk table='", a, "' column='", b, "'/>"]
     pk :: Bool
@@ -80,7 +91,7 @@ makeProperty pks c = (colName c, Inline s)
         colDescription c
     s =
       (mempty :: Schema)
-        & default_ .~ (decode . toS =<< colDefault c)
+        & default_ .~ (JSON.decode . toS =<< colDefault c)
         & description .~ d
         & enum_ .~ e
         & format ?~ colType c
@@ -111,7 +122,7 @@ makePreferParam ts =
   & schema .~ ParamOther ((mempty :: ParamOtherSchema)
     & in_ .~ ParamHeader
     & type_ ?~ SwaggerString
-    & enum_ .~ decode (encode ts))
+    & enum_ .~ JSON.decode (JSON.encode ts))
 
 makeProcParam :: ProcDescription -> [Referenced Param]
 makeProcParam pd =
@@ -162,7 +173,7 @@ makeParamDefs ti =
       & schema .~ ParamOther ((mempty :: ParamOtherSchema)
         & in_ .~ ParamHeader
         & type_ ?~ SwaggerString
-        & default_ .~ decode "\"items\""))
+        & default_ .~ JSON.decode "\"items\""))
   , ("offset", (mempty :: Param)
       & name        .~ "offset"
       & description ?~ "Limiting and Pagination"
@@ -303,9 +314,6 @@ postgrestSpec pds ti (s, h, p, b) sd pks = (mempty :: Swagger)
       h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))
       d = fromMaybe "This is a dynamic API generated by PostgREST" sd
 
-encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Maybe Text -> [PrimaryKey] ->  LByteString
-encodeOpenAPI pds ti uri sd pks = encode $ postgrestSpec pds ti uri sd pks
-
 pickProxy :: Maybe Text -> Maybe Proxy
 pickProxy proxy
   | isNothing proxy = Nothing
@@ -334,3 +342,18 @@ pickProxy proxy
              ("", "http")  -> 80
              ("", "https") -> 443
              _             -> readPort $ unpack $ tail $ pack port'
+
+proxyUri :: AppConfig -> (Text, Text, Integer, Text)
+proxyUri AppConfig{..} =
+  case pickProxy $ toS <$> configOpenApiServerProxyUri of
+    Just Proxy{..} ->
+      (proxyScheme, proxyHost, proxyPort, proxyPath)
+    Nothing ->
+      ("http", configServerHost, toInteger configServerPort, "/")
+
+openApiTableInfo :: DbStructure -> Table -> (Table, [Column], [Text])
+openApiTableInfo dbStructure table =
+  ( table
+  , tableCols dbStructure (tableSchema table) (tableName table)
+  , tablePKCols dbStructure (tableSchema table) (tableName table)
+  )