matebeamter/src/Control/User.hs
2019-09-17 21:29:56 +02:00

69 lines
1.5 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Control.User where
import Servant
import Servant.Client
import Servant.Server
import Data.String (fromString)
import Data.Text.I18n
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
-- imports from "mateamt"
import qualified "mateamt" API as MA
import qualified "mateamt" Types as MT
-- internal imports
import Types
import Client
import View
import Hash
import API
userSelectControl :: UserHandler UserSelectPage
userSelectControl = do
(ReadState l10n backend _) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
backend
case euser of
Right uss ->
return $ userSelectPage l10n loc uss
Left err ->
error $ show err
userNewControl :: UserHandler UserNewPage
userNewControl = do
(ReadState l10n backend _) <- ask
let loc = Locale "en"
return $ userNewPage l10n loc
userNewPostControl
:: MT.UserSubmit
-> UserHandler UserSelectPage
userNewPostControl us@(MT.UserSubmit ident email pass) = do
backend <- rsBackend <$> ask
hashedPass <- hashPassword pass
void $ liftIO $ runClientM
(userNew $us
{ MT.userSubmitPassHash = hashedPass
})
backend
throwError $ err303
{ errHeaders = [
("Location", "/" <> (fromString $ show $ linkURI $ userSelectLink))
]
}
userOverviewControl :: Int -> UserHandler UserOverviewPage
userOverviewControl uid = do
error "Not yet implemented"