content: {-# LANGUAGE ConstraintKinds       #-}
  {-# LANGUAGE DataKinds             #-}
  {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE LambdaCase            #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings     #-}
  {-# LANGUAGE ScopedTypeVariables   #-}
  {-# LANGUAGE TypeFamilies          #-}
  {-# LANGUAGE TypeOperators         #-}
  
  {-# OPTIONS_GHC #-}
  
  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
        -- FIXME: honor accept header
  
        -- FIXME: file upload:
        --   - file deletion is the responsibility of the handler.
        --   - content type and file name are lost in digestive-functors.
        --   - remember to set upload size limit!
  
        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
  
  
  -- | Handle a route of type @'FormH' htm html payload@.  'formAction' is used by digestive-functors
  -- as submit path for the HTML @FORM@ element.  'processor1' constructs the form, either as empty in
  -- response to a @GET@, or displaying validation errors in response to a @POST@.  'processor2'
  -- responds to a @POST@, handles the validated input values, and returns a new page displaying the
  -- result.  Note that the renderer is monadic so that it can have effects (such as e.g. flushing a
  -- message queue in the session state).
  formH :: forall payload m err htm html uri.
       (Monad m, MonadError err m, ConvertibleStrings uri ST)
    => IO :~> m                     -- liftIO
    -> uri                          -- formAction
    -> Form html m payload          -- processor1
    -> (payload -> m html)          -- processor2
    -> (View html -> uri -> m html) -- renderer
    -> 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)
  
  -- | Handle a route of type @'FormH' htm html payload@ and redirect afterwards.
  -- 'formAction' is used by digestive-functors as submit path for the HTML @FORM@ element.
  -- 'processor1' constructs the form, either as empty in response to a @GET@, or displaying validation
  -- errors in response to a @POST@.
  -- 'processor2' responds to a @POST@, handles the validated input values, calculates the redirection address.
  -- Note that the renderer is monadic so that it can have effects (such as e.g. flushing a
  -- message queue in the session state).
  formRedirectH :: forall payload m htm html uri.
       (MonadIO m, MonadError ServantErr m,
        ConvertibleStrings uri ST, ConvertibleStrings uri SBS)
    => uri                             -- ^ formAction
    -> Form html m payload             -- ^ processor1
    -> (payload -> m uri)              -- ^ processor2
    -> (View html -> uri -> m html)    -- ^ renderer
    -> 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 }
  