module Servant.Missing
( ThrowServantErr(..)
, MonadServantErr
, ThrowError500(..)
, MonadError500
, FormH
, FormReqBody
, FormData, getFormDataEnv, releaseFormTempFiles
, formH
, formRedirectH
, fromEnvIdentity
, redirect
) where
import Control.Lens (prism, Prism', (#))
import Control.Monad ((>=>))
import Control.Monad.Except (MonadError, throwError)
import Control.Monad.Except.Missing (finally)
import Control.Monad.Identity (Identity, runIdentity)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (InternalState, createInternalState, closeInternalState)
import Data.Proxy (Proxy(Proxy))
import Data.String.Conversions (ST, SBS, ConvertibleStrings, cs)
import Network.Wai.Parse (fileContent, parseRequestBody, tempFileBackEnd)
import Servant ((:<|>)((:<|>)), (:>), ServerT, (:~>)(Nat), unNat)
import Servant.Server (ServantErr(..), err500)
import Servant.Server.Internal (HasServer, route, addBodyCheck)
import Servant.Server.Internal.RoutingApplication (withRequest)
import Text.Digestive (Env, Form, FormInput(TextInput, FileInput), View, fromPath, getForm, postForm)
import qualified Servant
import qualified Data.Text.Encoding as STE
class ThrowServantErr err where
_ServantErr :: Prism' err ServantErr
throwServantErr :: MonadError err m => ServantErr -> m any
throwServantErr err = throwError $ _ServantErr # err
type MonadServantErr err m = (MonadError err m, ThrowServantErr err)
instance ThrowServantErr ServantErr where
_ServantErr = id
class ThrowError500 err where
error500 :: Prism' err String
throwError500 :: MonadError err m => String -> m b
throwError500 err = throwError $ error500 # err
type MonadError500 err m = (MonadError err m, ThrowError500 err)
instance ThrowError500 ServantErr where
error500 = prism (\msg -> err500 { errBody = cs msg })
(\err -> if errHTTPCode err == 500 then Right (cs (errBody err)) else Left err)
type FormH (htm :: [*]) html payload =
Servant.Get htm html
:<|> FormReqBody :> Servant.Post htm html
data FormReqBody
fromEnvIdentity :: Applicative m => Env Identity -> Env m
fromEnvIdentity env = pure . runIdentity . env
data FormData = FormData
{ _formEnv :: Env Identity
, _formTmpFilesState :: InternalState
}
getFormDataEnv :: FormData -> Env Identity
getFormDataEnv (FormData env _) = env
releaseFormTempFiles :: FormData -> IO ()
releaseFormTempFiles (FormData _ tmpFilesState) = closeInternalState tmpFilesState
instance HasServer sublayout context => HasServer (FormReqBody :> sublayout) context where
type ServerT (FormReqBody :> sublayout) m = FormData -> ServerT sublayout m
route Proxy context subserver =
route (Proxy :: Proxy sublayout) context (addBodyCheck subserver bodyCheck)
where
bodyCheck = withRequest $ \req -> do
tempFileState <- liftIO createInternalState
(params, files) <- liftIO $ parseRequestBody (tempFileBackEnd tempFileState) req
let env :: Env Identity
env query = pure $ f (TextInput . STE.decodeUtf8) params
++ f (FileInput . fileContent) files
where
f :: (a -> b) -> [(SBS, a)] -> [b]
f g = map (g . snd)
. filter ((== fromPath query) . STE.decodeUtf8 . fst)
return $ FormData env tempFileState
formH :: forall payload m err htm html uri.
(Monad m, MonadError err m, ConvertibleStrings uri ST)
=> IO :~> m
-> uri
-> Form html m payload
-> (payload -> m html)
-> (View html -> uri -> m html)
-> ServerT (FormH htm html payload) m
formH liftIO' formAction processor1 processor2 renderer = getH :<|> postH
where
getH :: m html
getH = do
v <- getForm (cs formAction) processor1
renderer v formAction
postH :: FormData -> m html
postH (FormData env tmpFilesState) = do
(v, mpayload) <- postForm (cs formAction) processor1 (\_ -> pure $ fromEnvIdentity env)
(case mpayload of
Just payload -> processor2 payload
Nothing -> renderer v formAction)
`finally` unNat liftIO' (closeInternalState tmpFilesState)
formRedirectH :: forall payload m htm html uri.
(MonadIO m, MonadError ServantErr m,
ConvertibleStrings uri ST, ConvertibleStrings uri SBS)
=> uri
-> Form html m payload
-> (payload -> m uri)
-> (View html -> uri -> m html)
-> ServerT (FormH htm html payload) m
formRedirectH formAction processor1 processor2 =
formH (Nat liftIO) formAction processor1 (processor2 >=> redirect)
redirect :: (MonadServantErr err m, ConvertibleStrings uri SBS) => uri -> m a
redirect uri = throwServantErr $
Servant.err303 { errHeaders = ("Location", cs uri) : errHeaders Servant.err303 }