linted
This commit is contained in:
parent
0216209c56
commit
b29daaf841
15 changed files with 320 additions and 271 deletions
|
@ -1,10 +1,8 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE PackageImports #-}
|
||||||
|
@ -13,7 +11,7 @@ module API where
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.Links
|
import Servant.Links
|
||||||
import Servant.RawM
|
-- import Servant.RawM
|
||||||
import Servant.HTML.Blaze
|
import Servant.HTML.Blaze
|
||||||
|
|
||||||
import Data.Proxy
|
import Data.Proxy
|
||||||
|
@ -57,7 +55,6 @@ type UserAPI =
|
||||||
:> ReqBody '[FormUrlEncoded] AuthReturn
|
:> ReqBody '[FormUrlEncoded] AuthReturn
|
||||||
:> Post '[HTML] UserSelectPage
|
:> Post '[HTML] UserSelectPage
|
||||||
:<|> "auth" :> "logout"
|
:<|> "auth" :> "logout"
|
||||||
-- :> ReqBody '[FormUrlEncoded] ()
|
|
||||||
:> Post '[HTML] UserOverviewPage
|
:> Post '[HTML] UserOverviewPage
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
@ -1,9 +1,8 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
@ -13,23 +12,90 @@ module Client where
|
||||||
|
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
|
import Servant.Client.Core.Auth
|
||||||
import Network.HTTP.Client hiding (Proxy)
|
import Servant.Client.Core.Request
|
||||||
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
|
|
||||||
-- imports from mateamt
|
-- imports from mateamt
|
||||||
|
|
||||||
import qualified "mateamt" API as MT
|
import qualified "mateamt" API as MA
|
||||||
import qualified "mateamt" Types as MT
|
import qualified "mateamt" Types as MT
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Types
|
mateApi :: Proxy MA.MateAPI
|
||||||
|
|
||||||
mateApi :: Proxy MT.MateAPI
|
|
||||||
mateApi = Proxy
|
mateApi = Proxy
|
||||||
|
|
||||||
|
authGet :: MT.TicketRequest -> ClientM MT.AuthInfo
|
||||||
|
authSend :: MT.AuthRequest -> ClientM MT.AuthResult
|
||||||
|
authLogout :: AuthenticatedRequest (AuthProtect "header-auth") -> ClientM ()
|
||||||
|
authManageList
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> ClientM [MT.AuthOverview]
|
||||||
|
authManageNewAuth
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.AuthSubmit
|
||||||
|
-> ClientM Int
|
||||||
|
authManageDeleteAuth
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> Int
|
||||||
|
-> ClientM ()
|
||||||
|
userNew :: MT.UserSubmit -> ClientM Int
|
||||||
|
userGet
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> ClientM MT.UserDetails
|
||||||
|
userUpdate
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.UserDetailsSubmit
|
||||||
|
-> ClientM ()
|
||||||
|
userList :: Maybe MT.UserRefine -> ClientM [MT.UserSummary]
|
||||||
|
userRecharge
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.UserRecharge
|
||||||
|
-> ClientM ()
|
||||||
|
userTransfer
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.UserTransfer
|
||||||
|
-> ClientM ()
|
||||||
|
productNew
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.ProductSubmit
|
||||||
|
-> ClientM Int
|
||||||
|
productOverview :: Int -> ClientM MT.ProductOverview
|
||||||
|
productStockRefill
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> [MT.AmountRefill]
|
||||||
|
-> ClientM ()
|
||||||
|
productStockUpdate
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> [MT.AmountUpdate]
|
||||||
|
-> ClientM ()
|
||||||
|
productList :: Maybe MT.ProductRefine -> ClientM [MT.ProductOverview]
|
||||||
|
productShortList :: Maybe MT.ProductRefine -> ClientM [MT.ProductShortOverview]
|
||||||
|
buy
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> [MT.PurchaseDetail]
|
||||||
|
-> ClientM MT.PurchaseResult
|
||||||
|
journalShow
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> Maybe Int
|
||||||
|
-> Maybe Int
|
||||||
|
-> ClientM [MT.JournalEntry]
|
||||||
|
avatarGet
|
||||||
|
:: Int
|
||||||
|
-> (Servant.Client.Core.Request.Request
|
||||||
|
-> Servant.Client.Core.Request.Request)
|
||||||
|
-> ClientM Response
|
||||||
|
avatarInsert
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> MT.AvatarData
|
||||||
|
-> ClientM Int
|
||||||
|
avatarUpdate
|
||||||
|
:: AuthenticatedRequest (AuthProtect "header-auth")
|
||||||
|
-> Int
|
||||||
|
-> MT.AvatarData
|
||||||
|
-> ClientM ()
|
||||||
|
avatarList :: ClientM [MT.Avatar]
|
||||||
|
|
||||||
( authGet :<|>
|
( authGet :<|>
|
||||||
authSend :<|>
|
authSend :<|>
|
||||||
authLogout :<|>
|
authLogout :<|>
|
||||||
|
|
|
@ -9,4 +9,4 @@ import Servant.Client.Core
|
||||||
type instance AuthClientData (AuthProtect "header-auth") = String
|
type instance AuthClientData (AuthProtect "header-auth") = String
|
||||||
|
|
||||||
authenticateReq :: String -> Request -> Request
|
authenticateReq :: String -> Request -> Request
|
||||||
authenticateReq s req = addHeader "Authentication" s req
|
authenticateReq = addHeader "Authentication"
|
||||||
|
|
|
@ -49,7 +49,7 @@ authControl mcookie mDestination = do
|
||||||
mAuthUser = lookup "x-auth-user" =<< mParsedCookie
|
mAuthUser = lookup "x-auth-user" =<< mParsedCookie
|
||||||
mToken = lookup "x-token" =<< mParsedCookie
|
mToken = lookup "x-token" =<< mParsedCookie
|
||||||
case (mAuthUser, mToken) of
|
case (mAuthUser, mToken) of
|
||||||
(Just authUser, Just _) -> do
|
(Just authUser, Just _) ->
|
||||||
throwError $ case mDestination of
|
throwError $ case mDestination of
|
||||||
Just destination ->
|
Just destination ->
|
||||||
err303
|
err303
|
||||||
|
@ -74,7 +74,7 @@ authControl mcookie mDestination = do
|
||||||
, MT.SecondaryPass
|
, MT.SecondaryPass
|
||||||
]
|
]
|
||||||
eAuthInfos <- zip passes <$>
|
eAuthInfos <- zip passes <$>
|
||||||
(liftIO $ mapM
|
liftIO (mapM
|
||||||
(\req -> runClientM
|
(\req -> runClientM
|
||||||
(authGet req)
|
(authGet req)
|
||||||
backend
|
backend
|
||||||
|
@ -85,7 +85,7 @@ authControl mcookie mDestination = do
|
||||||
then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $
|
then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $
|
||||||
unzip eAuthInfos)
|
unzip eAuthInfos)
|
||||||
else throwError $ err400
|
else throwError $ err400
|
||||||
{ errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos
|
{ errBody = fromString $ show $ lefts $ map snd eAuthInfos
|
||||||
}
|
}
|
||||||
(Nothing, _) ->
|
(Nothing, _) ->
|
||||||
error "Error handling not yet implemented properly."
|
error "Error handling not yet implemented properly."
|
||||||
|
@ -105,10 +105,10 @@ authControl mcookie mDestination = do
|
||||||
ticketHeaders = map
|
ticketHeaders = map
|
||||||
(\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) ->
|
(\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) ->
|
||||||
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
|
"x-ticket-"<> fromString (show $ fromEnum method) <>"=" <>
|
||||||
(fromString $ T.unpack ticket) <> ";Path=/")
|
fromString (T.unpack ticket) <> ";Path=/")
|
||||||
tupAuthInfos
|
tupAuthInfos
|
||||||
return $
|
return $
|
||||||
addHeader (ticketHeaders !! 0) $
|
addHeader (head ticketHeaders) $
|
||||||
addHeader (ticketHeaders !! 1) $
|
addHeader (ticketHeaders !! 1) $
|
||||||
authPage l10n loc mDestination
|
authPage l10n loc mDestination
|
||||||
|
|
||||||
|
@ -177,8 +177,8 @@ authLogoutControl
|
||||||
authLogoutControl mcookie = do
|
authLogoutControl mcookie = do
|
||||||
(ReadState _ backend _) <- ask
|
(ReadState _ backend _) <- ask
|
||||||
let mParsedCookie = fmap parseCookieText mcookie
|
let mParsedCookie = fmap parseCookieText mcookie
|
||||||
token = T.unpack $ fromMaybe "secret" $
|
token = T.unpack $ fromMaybe "secret"
|
||||||
((lookup "x-token") =<< mParsedCookie)
|
(lookup "x-token" =<< mParsedCookie)
|
||||||
eReturn <- liftIO $ runClientM
|
eReturn <- liftIO $ runClientM
|
||||||
(authLogout (mkAuthenticatedRequest token authenticateReq))
|
(authLogout (mkAuthenticatedRequest token authenticateReq))
|
||||||
backend
|
backend
|
||||||
|
|
|
@ -7,7 +7,6 @@ module Control.User where
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import Servant.Client.Core.Auth
|
import Servant.Client.Core.Auth
|
||||||
import Servant.Server
|
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
|
||||||
|
@ -17,15 +16,14 @@ import Data.Text.I18n
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Either.Combinators (leftToMaybe)
|
import Data.Either.Combinators (leftToMaybe)
|
||||||
|
|
||||||
import Control.Monad (void, when)
|
import Control.Monad (void)
|
||||||
import Control.Monad.Reader (ask)
|
import Control.Monad.Reader (ask, asks)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
import Network.HTTP.Types.Status
|
import Network.HTTP.Types.Status
|
||||||
|
|
||||||
-- imports from "mateamt"
|
-- imports from "mateamt"
|
||||||
|
|
||||||
import qualified "mateamt" API as MA
|
|
||||||
import qualified "mateamt" Types as MT
|
import qualified "mateamt" Types as MT
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
@ -44,7 +42,7 @@ userSelectControl mcookie = do
|
||||||
let loc = Locale
|
let loc = Locale
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||||
euser <- liftIO $ runClientM
|
euser <- liftIO $ runClientM
|
||||||
(userList (Nothing))
|
(userList Nothing)
|
||||||
backend
|
backend
|
||||||
case euser of
|
case euser of
|
||||||
Right uss ->
|
Right uss ->
|
||||||
|
@ -54,7 +52,7 @@ userSelectControl mcookie = do
|
||||||
|
|
||||||
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
|
userNewControl :: Maybe T.Text -> UserHandler UserNewPage
|
||||||
userNewControl mcookie = do
|
userNewControl mcookie = do
|
||||||
(ReadState l10n backend _) <- ask
|
(ReadState l10n _ _) <- ask
|
||||||
let loc = Locale
|
let loc = Locale
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||||
return $ userNewPage l10n loc
|
return $ userNewPage l10n loc
|
||||||
|
@ -63,8 +61,8 @@ userNewPostControl
|
||||||
:: Maybe T.Text
|
:: Maybe T.Text
|
||||||
-> MT.UserSubmit
|
-> MT.UserSubmit
|
||||||
-> UserHandler UserSelectPage
|
-> UserHandler UserSelectPage
|
||||||
userNewPostControl _ us@(MT.UserSubmit ident email pass) = do
|
userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do
|
||||||
backend <- rsBackend <$> ask
|
backend <- asks rsBackend
|
||||||
hashedPass <- hashPassword pass
|
hashedPass <- hashPassword pass
|
||||||
void $ liftIO $ runClientM
|
void $ liftIO $ runClientM
|
||||||
(userNew $us
|
(userNew $us
|
||||||
|
@ -89,7 +87,7 @@ userOverviewControl mcookie uid mRefine = do
|
||||||
(lookup "x-auth-user" =<< mParsedCookie)
|
(lookup "x-auth-user" =<< mParsedCookie)
|
||||||
mMethod = T.unpack <$>
|
mMethod = T.unpack <$>
|
||||||
(lookup "x-method" =<< mParsedCookie)
|
(lookup "x-method" =<< mParsedCookie)
|
||||||
euser <- liftIO $ do
|
euser <- liftIO $
|
||||||
runClientM
|
runClientM
|
||||||
(userGet (mkAuthenticatedRequest token authenticateReq))
|
(userGet (mkAuthenticatedRequest token authenticateReq))
|
||||||
backend
|
backend
|
||||||
|
@ -129,7 +127,7 @@ userOverviewControl mcookie uid mRefine = do
|
||||||
}
|
}
|
||||||
(Left uerr, Left perr) ->
|
(Left uerr, Left perr) ->
|
||||||
throwError $ err500
|
throwError $ err500
|
||||||
{ errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr)
|
{ errBody = fromString (show uerr) <> " " <> fromString (show perr)
|
||||||
}
|
}
|
||||||
|
|
||||||
userManageControl
|
userManageControl
|
||||||
|
@ -141,15 +139,15 @@ userManageControl mcookie uid = do
|
||||||
let loc = Locale
|
let loc = Locale
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
||||||
mParsedCookie = fmap parseCookieText mcookie
|
mParsedCookie = fmap parseCookieText mcookie
|
||||||
token = T.unpack $ fromMaybe "secret" $
|
token = T.unpack $ fromMaybe "secret"
|
||||||
((lookup "x-token") =<< mParsedCookie)
|
(lookup "x-token" =<< mParsedCookie)
|
||||||
mAuthUser = T.unpack <$>
|
mAuthUser = T.unpack <$>
|
||||||
((lookup "x-auth-user") =<< mParsedCookie)
|
(lookup "x-auth-user" =<< mParsedCookie)
|
||||||
eUserDetails <- liftIO $ do
|
eUserDetails <- liftIO $
|
||||||
runClientM
|
runClientM
|
||||||
(userGet (mkAuthenticatedRequest token authenticateReq))
|
(userGet (mkAuthenticatedRequest token authenticateReq))
|
||||||
backend
|
backend
|
||||||
eAuthOverviews <- liftIO $ do
|
eAuthOverviews <- liftIO $
|
||||||
runClientM
|
runClientM
|
||||||
(authManageList (mkAuthenticatedRequest token authenticateReq))
|
(authManageList (mkAuthenticatedRequest token authenticateReq))
|
||||||
backend
|
backend
|
||||||
|
@ -165,15 +163,18 @@ userManageControl mcookie uid = do
|
||||||
(Just $ userManageLink uid)
|
(Just $ userManageLink uid)
|
||||||
[leftToMaybe (fst err), leftToMaybe (snd err)]
|
[leftToMaybe (fst err), leftToMaybe (snd err)]
|
||||||
|
|
||||||
|
userManageDetailsSubmitControl
|
||||||
|
:: Maybe T.Text
|
||||||
|
-> Int
|
||||||
|
-> MT.UserDetailsSubmit
|
||||||
|
-> UserHandler UserOverviewPage
|
||||||
userManageDetailsSubmitControl mcookie uid uds = do
|
userManageDetailsSubmitControl mcookie uid uds = do
|
||||||
(ReadState l10n backend _) <- ask
|
(ReadState _ backend _) <- ask
|
||||||
let loc = Locale
|
let mParsedCookie = fmap parseCookieText mcookie
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
token = T.unpack $ fromMaybe "secret"
|
||||||
mParsedCookie = fmap parseCookieText mcookie
|
(lookup "x-token" =<< mParsedCookie)
|
||||||
token = T.unpack $ fromMaybe "secret" $
|
|
||||||
((lookup "x-token") =<< mParsedCookie)
|
|
||||||
mAuthUser = T.unpack <$>
|
mAuthUser = T.unpack <$>
|
||||||
((lookup "x-auth-user") =<< mParsedCookie)
|
(lookup "x-auth-user" =<< mParsedCookie)
|
||||||
eReturn <- liftIO $ runClientM
|
eReturn <- liftIO $ runClientM
|
||||||
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
|
(userUpdate (mkAuthenticatedRequest token authenticateReq) uds)
|
||||||
backend
|
backend
|
||||||
|
@ -182,15 +183,18 @@ userManageDetailsSubmitControl mcookie uid uds = do
|
||||||
Left err ->
|
Left err ->
|
||||||
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
|
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
|
||||||
|
|
||||||
|
userManageAuthCreateControl
|
||||||
|
:: Maybe T.Text
|
||||||
|
-> Int
|
||||||
|
-> AuthSubmitReturn
|
||||||
|
-> UserHandler UserOverviewPage
|
||||||
userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
|
userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = do
|
||||||
(ReadState l10n backend _) <- ask
|
(ReadState _ backend _) <- ask
|
||||||
let loc = Locale
|
let mParsedCookie = fmap parseCookieText mcookie
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
token = T.unpack $ fromMaybe "secret"
|
||||||
mParsedCookie = fmap parseCookieText mcookie
|
(lookup "x-token" =<< mParsedCookie)
|
||||||
token = T.unpack $ fromMaybe "secret" $
|
|
||||||
((lookup "x-token") =<< mParsedCookie)
|
|
||||||
mAuthUser = T.unpack <$>
|
mAuthUser = T.unpack <$>
|
||||||
((lookup "x-auth-user") =<< mParsedCookie)
|
(lookup "x-auth-user" =<< mParsedCookie)
|
||||||
hashedPass <- hashPassword pass
|
hashedPass <- hashPassword pass
|
||||||
eReturn <- liftIO $ runClientM
|
eReturn <- liftIO $ runClientM
|
||||||
(authManageNewAuth
|
(authManageNewAuth
|
||||||
|
@ -203,15 +207,18 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) =
|
||||||
Left err ->
|
Left err ->
|
||||||
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
|
handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err]
|
||||||
|
|
||||||
|
userManageAuthDeleteControl
|
||||||
|
:: Maybe T.Text
|
||||||
|
-> Int
|
||||||
|
-> AuthDetailId
|
||||||
|
-> UserHandler UserOverviewPage
|
||||||
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
|
userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do
|
||||||
(ReadState l10n backend _) <- ask
|
(ReadState _ backend _) <- ask
|
||||||
let loc = Locale
|
let mParsedCookie = fmap parseCookieText mcookie
|
||||||
(fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie)
|
token = T.unpack $ fromMaybe "secret"
|
||||||
mParsedCookie = fmap parseCookieText mcookie
|
(lookup "x-token" =<< mParsedCookie)
|
||||||
token = T.unpack $ fromMaybe "secret" $
|
|
||||||
((lookup "x-token") =<< mParsedCookie)
|
|
||||||
mAuthUser = T.unpack <$>
|
mAuthUser = T.unpack <$>
|
||||||
((lookup "x-auth-user") =<< mParsedCookie)
|
(lookup "x-auth-user" =<< mParsedCookie)
|
||||||
eReturn <- liftIO $ runClientM
|
eReturn <- liftIO $ runClientM
|
||||||
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
|
(authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid)
|
||||||
backend
|
backend
|
||||||
|
|
|
@ -10,7 +10,7 @@ import Data.ByteString
|
||||||
import Data.ByteString.Random (random)
|
import Data.ByteString.Random (random)
|
||||||
import qualified Data.ByteString.Base64 as B64
|
import qualified Data.ByteString.Base64 as B64
|
||||||
|
|
||||||
import Control.Monad.Reader (ask)
|
import Control.Monad.Reader (asks)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
@ -21,8 +21,8 @@ hashPassword
|
||||||
:: T.Text
|
:: T.Text
|
||||||
-> UserHandler T.Text
|
-> UserHandler T.Text
|
||||||
hashPassword passwd = do
|
hashPassword passwd = do
|
||||||
(HashParams iter _ outputl) <- rsHashParams <$> ask
|
(HashParams iter _ outputl) <- asks rsHashParams
|
||||||
let saltl = 0
|
let saltl = 0 :: Int
|
||||||
salt <- liftIO $ random (fromIntegral saltl)
|
salt <- liftIO $ random (fromIntegral saltl)
|
||||||
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
|
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
|
||||||
return $ decodeUtf8 $ B64.encode hash
|
return $ decodeUtf8 $ B64.encode hash
|
||||||
|
|
10
src/Main.hs
10
src/Main.hs
|
@ -3,7 +3,6 @@
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.Server
|
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
|
|
||||||
import Network.Wai.Handler.Warp
|
import Network.Wai.Handler.Warp
|
||||||
|
@ -13,32 +12,31 @@ import Network.HTTP.Client hiding (Proxy)
|
||||||
|
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
|
||||||
import Data.Text.I18n
|
|
||||||
import Data.Text.I18n.Po
|
import Data.Text.I18n.Po
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import API
|
import API
|
||||||
import Types
|
import Types
|
||||||
import View
|
|
||||||
import Control
|
import Control
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
manager <- newManager defaultManagerSettings
|
mngr <- newManager defaultManagerSettings
|
||||||
(l10n, _) <- getL10n "./locales"
|
(l10n, _) <- getL10n "./locales"
|
||||||
withStdoutLogger $ \ilog -> do
|
withStdoutLogger $ \ilog -> do
|
||||||
let settings = setPort 3000 $ setLogger ilog defaultSettings
|
let settings = setPort 3000 $ setLogger ilog defaultSettings
|
||||||
initState = ReadState
|
initState = ReadState
|
||||||
-- { rsManager = manager
|
-- { rsManager = manager
|
||||||
{ rsL10n = l10n
|
{ rsL10n = l10n
|
||||||
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
|
, rsBackend = mkClientEnv mngr (BaseUrl Http "localhost" 8000 "")
|
||||||
, rsHashParams = recommendedHashParams
|
, rsHashParams = recommendedHashParams
|
||||||
}
|
}
|
||||||
|
|
||||||
runSettings settings (userApp initState)
|
runSettings settings (userApp initState)
|
||||||
|
|
||||||
userApp initState = serveWithContext userApi (EmptyContext) $
|
userApp :: ReadState -> Application
|
||||||
|
userApp initState = serveWithContext userApi EmptyContext $
|
||||||
hoistServerWithContext
|
hoistServerWithContext
|
||||||
userApi
|
userApi
|
||||||
Proxy
|
Proxy
|
||||||
|
|
|
@ -1,3 +0,0 @@
|
||||||
module Model.Auth where
|
|
||||||
|
|
||||||
|
|
|
@ -1,7 +0,0 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE PackageImports #-}
|
|
||||||
module Model.User where
|
|
||||||
|
|
||||||
import qualified "mateamt" Types as MT
|
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,5 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE PackageImports #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
|
@ -5,14 +7,6 @@ module Types.Orphans where
|
||||||
|
|
||||||
import qualified "mateamt" Types as MT
|
import qualified "mateamt" Types as MT
|
||||||
|
|
||||||
import GHC.Generics
|
|
||||||
|
|
||||||
import Text.Blaze
|
|
||||||
|
|
||||||
import Text.Read (readEither)
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
import Servant.API
|
import Servant.API
|
||||||
import Servant.HTML.Blaze
|
import Servant.HTML.Blaze
|
||||||
import Web.Internal.FormUrlEncoded
|
import Web.Internal.FormUrlEncoded
|
||||||
|
|
|
@ -1,4 +1,3 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
module Types.Page where
|
module Types.Page where
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
@ -44,9 +43,9 @@ template
|
||||||
template (Page title favicon meta style) content =
|
template (Page title favicon meta style) content =
|
||||||
H.docTypeHtml $ do
|
H.docTypeHtml $ do
|
||||||
H.head $ do
|
H.head $ do
|
||||||
H.title $ H.toHtml $ title
|
H.title $ H.toHtml title
|
||||||
meta
|
meta
|
||||||
favicon
|
favicon
|
||||||
style
|
style
|
||||||
H.body $
|
H.body
|
||||||
content
|
content
|
||||||
|
|
14
src/Util.hs
14
src/Util.hs
|
@ -3,12 +3,12 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
{-# LANGUAGE PackageImports #-}
|
{-# LANGUAGE PackageImports #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
module Util where
|
module Util where
|
||||||
|
|
||||||
import Servant hiding (addHeader)
|
import Servant hiding (addHeader)
|
||||||
import Servant.Client
|
import Servant.Client
|
||||||
import Servant.Client.Core.Request
|
import Servant.Client.Core.Request
|
||||||
import Servant.Client.Core.Request (addHeader)
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Text.Lazy.Encoding
|
import Data.Text.Lazy.Encoding
|
||||||
|
@ -58,7 +58,7 @@ redirect303
|
||||||
redirect303 link =
|
redirect303 link =
|
||||||
err303
|
err303
|
||||||
{ errHeaders =
|
{ errHeaders =
|
||||||
[ ("Location", "/" <> (fromString $ show $ linkURI link))
|
[ ("Location", "/" <> fromString (show $ linkURI link))
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -77,7 +77,7 @@ handleErrors
|
||||||
-> UserHandler UserOverviewPage
|
-> UserHandler UserOverviewPage
|
||||||
handleErrors mAuthUser mLink merrs = do
|
handleErrors mAuthUser mLink merrs = do
|
||||||
codes <- mapM
|
codes <- mapM
|
||||||
(\eerr -> case eerr of
|
(\case
|
||||||
Just (FailureResponse _ resp) ->
|
Just (FailureResponse _ resp) ->
|
||||||
return $ statusCode (responseStatusCode resp)
|
return $ statusCode (responseStatusCode resp)
|
||||||
Just err ->
|
Just err ->
|
||||||
|
@ -88,7 +88,7 @@ handleErrors mAuthUser mLink merrs = do
|
||||||
return 200
|
return 200
|
||||||
)
|
)
|
||||||
merrs
|
merrs
|
||||||
if (any (== 401) codes)
|
if 401 `elem` codes
|
||||||
then
|
then
|
||||||
redirectOverAuth mAuthUser mLink Nothing
|
redirectOverAuth mAuthUser mLink Nothing
|
||||||
else
|
else
|
||||||
|
@ -99,14 +99,14 @@ handleErrors mAuthUser mLink merrs = do
|
||||||
redirectOverAuth
|
redirectOverAuth
|
||||||
:: Maybe Int
|
:: Maybe Int
|
||||||
-> Maybe Link
|
-> Maybe Link
|
||||||
-> Maybe (MT.ProductRefine)
|
-> Maybe MT.ProductRefine
|
||||||
-> UserHandler UserOverviewPage
|
-> UserHandler UserOverviewPage
|
||||||
redirectOverAuth muid mLink mRefine = do
|
redirectOverAuth muid mLink mRefine = do
|
||||||
let redirectHeaders = errHeaders $
|
let redirectHeaders = errHeaders $
|
||||||
redirect303 (authLink (Just $ "/" <>
|
redirect303 (authLink (Just $ "/" <>
|
||||||
fromString (show $ linkURI (case (mLink, muid) of
|
fromString (show $ linkURI (case (mLink, muid) of
|
||||||
(Just link, _) -> link
|
(Just link, _) -> link
|
||||||
(Nothing, Just uid) -> userOverviewLink uid Nothing
|
(Nothing, Just uid) -> userOverviewLink uid mRefine
|
||||||
_ -> userSelectLink
|
_ -> userSelectLink
|
||||||
))))
|
))))
|
||||||
throwError
|
throwError
|
||||||
|
@ -114,7 +114,7 @@ redirectOverAuth muid mLink mRefine = do
|
||||||
{ errHeaders = redirectHeaders ++ (case muid of
|
{ errHeaders = redirectHeaders ++ (case muid of
|
||||||
Just uid ->
|
Just uid ->
|
||||||
[ ( "Set-Cookie"
|
[ ( "Set-Cookie"
|
||||||
, "x-auth-user=" <> (fromString $ show uid) <> "; Path=/"
|
, "x-auth-user=" <> fromString (show uid) <> "; Path=/"
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
Nothing ->
|
Nothing ->
|
||||||
|
|
|
@ -36,10 +36,9 @@ authPage l10n locale mDestination = scaffold
|
||||||
" - " <>
|
" - " <>
|
||||||
translate "Authentication"
|
translate "Authentication"
|
||||||
)
|
)
|
||||||
$ do
|
$ H.p $ H.form
|
||||||
H.p $ H.form
|
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <> (fromString $ show $ linkURI $
|
H.! HA.action ("/" <> fromString (show $ linkURI $
|
||||||
authPostLink mDestination))
|
authPostLink mDestination))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
||||||
H.div H.! HA.class_ "form-group required" $ do
|
H.div H.! HA.class_ "form-group required" $ do
|
||||||
|
@ -67,7 +66,7 @@ authPage l10n locale mDestination = scaffold
|
||||||
H.! HA.type_ "password"
|
H.! HA.type_ "password"
|
||||||
H.! HA.required ""
|
H.! HA.required ""
|
||||||
H.! HA.value ""
|
H.! HA.value ""
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
|
|
@ -24,9 +24,9 @@ scaffold
|
||||||
-> H.Html
|
-> H.Html
|
||||||
-> H.Html
|
-> H.Html
|
||||||
scaffold l10n locale page content = template page $ do
|
scaffold l10n locale page content = template page $ do
|
||||||
H.header $ H.nav $ H.ul $ do
|
H.header $ H.nav $ H.ul $
|
||||||
H.li $ H.a H.! H.href ("/" <> (fromString $ show $ linkURI $ userSelectLink)) $
|
H.li $ H.a H.! H.href ("/" <> fromString (show $ linkURI userSelectLink)) $
|
||||||
H.toHtml $ localize l10n locale $ gettext "Home"
|
H.toHtml $ localize l10n locale $ gettext "Home"
|
||||||
H.hr
|
H.hr
|
||||||
H.div H.! H.id "main" H.! H.role "main" $ do
|
H.div H.! H.id "main" H.! H.role "main" $
|
||||||
content
|
content
|
||||||
|
|
|
@ -13,7 +13,7 @@ import Data.Text.I18n
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.String (fromString)
|
||||||
|
|
||||||
import Data.Maybe (isJust, fromJust, fromMaybe)
|
import Data.Maybe (isJust, fromJust)
|
||||||
|
|
||||||
-- imports from mateamt
|
-- imports from mateamt
|
||||||
|
|
||||||
|
@ -32,16 +32,16 @@ userSelectPage
|
||||||
-> [MT.UserSummary]
|
-> [MT.UserSummary]
|
||||||
-> UserSelectPage
|
-> UserSelectPage
|
||||||
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
|
userSelectPage l10n locale uss = scaffold l10n locale (initPage $
|
||||||
(translate "Matebeamter") <>
|
translate "Matebeamter" <>
|
||||||
" - " <>
|
" - " <>
|
||||||
(translate "Home")
|
translate "Home"
|
||||||
) $ do
|
) $ do
|
||||||
mapM_ (\(MT.UserSummary uid ident _) -> do
|
mapM_ (\(MT.UserSummary uid ident _) ->
|
||||||
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $
|
H.a H.! HA.href ("/" <> fromString (show $ linkURI $
|
||||||
userOverviewLink uid Nothing)) $
|
userOverviewLink uid Nothing)) $
|
||||||
H.toHtml ident
|
H.toHtml ident
|
||||||
) uss
|
) uss
|
||||||
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
|
H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $
|
||||||
H.toHtml $ translate "New user"
|
H.toHtml $ translate "New user"
|
||||||
where
|
where
|
||||||
translate = localize l10n locale . gettext
|
translate = localize l10n locale . gettext
|
||||||
|
@ -54,23 +54,23 @@ userOverviewPage
|
||||||
-> [MT.ProductShortOverview]
|
-> [MT.ProductShortOverview]
|
||||||
-> UserOverviewPage
|
-> UserOverviewPage
|
||||||
userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
|
userOverviewPage l10n locale method ud pos = scaffold l10n locale (initPage $
|
||||||
(localize l10n locale $ gettext "Matebeamter") <>
|
localize l10n locale (gettext "Matebeamter") <>
|
||||||
" - " <>
|
" - " <>
|
||||||
(localize l10n locale $ gettext "User Menu for ") <>
|
localize l10n locale (gettext "User Menu for ") <>
|
||||||
(MT.userDetailsIdent ud)
|
MT.userDetailsIdent ud
|
||||||
) $ do
|
) $ do
|
||||||
H.p $ H.toHtml $ (translate "Welcome back, ") <> (MT.userDetailsIdent ud)
|
H.p $ H.toHtml $ translate "Welcome back, " <> MT.userDetailsIdent ud
|
||||||
<> "!"
|
<> "!"
|
||||||
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
|
H.p H.!? (MT.userDetailsBalance ud < 0, HA.class_ "debt") $ H.toHtml $
|
||||||
(translate "Your current balance is") <>
|
translate "Your current balance is" <>
|
||||||
": " <>
|
": " <>
|
||||||
(formatMoney $ MT.userDetailsBalance ud)
|
formatMoney (MT.userDetailsBalance ud)
|
||||||
-- TODO: Add currency symbol
|
-- TODO: Add currency symbol
|
||||||
H.p $ H.form
|
H.p $ H.form
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <> (fromString $ show $ linkURI $ authLogoutLink))
|
H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
@ -92,7 +92,7 @@ userSettingsPointer
|
||||||
-> Int
|
-> Int
|
||||||
-> H.Html
|
-> H.Html
|
||||||
userSettingsPointer l10n locale uid =
|
userSettingsPointer l10n locale uid =
|
||||||
H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userManageLink uid)) $
|
H.a H.! HA.href ("/" <> fromString (show $ linkURI $ userManageLink uid)) $
|
||||||
H.toHtml $ translate "Manage user settings"
|
H.toHtml $ translate "Manage user settings"
|
||||||
where
|
where
|
||||||
translate = localize l10n locale . gettext
|
translate = localize l10n locale . gettext
|
||||||
|
@ -104,7 +104,7 @@ productList pos =
|
||||||
H.p $
|
H.p $
|
||||||
H.ul H.! HA.class_ "product_list" $
|
H.ul H.! HA.class_ "product_list" $
|
||||||
mapM_
|
mapM_
|
||||||
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
|
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) ->
|
||||||
H.li H.! HA.class_ "product" H.!?
|
H.li H.! HA.class_ "product" H.!?
|
||||||
(isJust avatarid
|
(isJust avatarid
|
||||||
, productBgStyle (fromString $ show $ fromJust avatarid)
|
, productBgStyle (fromString $ show $ fromJust avatarid)
|
||||||
|
@ -129,13 +129,12 @@ userNewPage
|
||||||
-> Locale
|
-> Locale
|
||||||
-> UserNewPage
|
-> UserNewPage
|
||||||
userNewPage l10n locale = scaffold l10n locale (initPage $
|
userNewPage l10n locale = scaffold l10n locale (initPage $
|
||||||
(translate "Matebeamter") <>
|
translate "Matebeamter" <>
|
||||||
" - " <>
|
" - " <>
|
||||||
(translate "Create new user")
|
translate "Create new user"
|
||||||
) $ do
|
) $ H.p $ H.form
|
||||||
H.p $ H.form
|
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <> (fromString $ show $ linkURI $ userNewPostLink))
|
H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $ do
|
||||||
H.div H.! HA.class_ "form-group required" $ do
|
H.div H.! HA.class_ "form-group required" $ do
|
||||||
H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
|
H.label H.! HA.for "username" $ H.toHtml $ translate "Username"
|
||||||
|
@ -164,7 +163,7 @@ userNewPage l10n locale = scaffold l10n locale (initPage $
|
||||||
H.! HA.type_ "password"
|
H.! HA.type_ "password"
|
||||||
H.! HA.required ""
|
H.! HA.required ""
|
||||||
H.! HA.value ""
|
H.! HA.value ""
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
@ -180,14 +179,13 @@ userManagePage
|
||||||
-> UserManagePage
|
-> UserManagePage
|
||||||
userManagePage l10n locale userDetails authOverviews =
|
userManagePage l10n locale userDetails authOverviews =
|
||||||
scaffold l10n locale (initPage $
|
scaffold l10n locale (initPage $
|
||||||
(translate "Matebeamter") <>
|
translate "Matebeamter" <>
|
||||||
" - " <>
|
" - " <>
|
||||||
(translate "Manage user data")
|
translate "Manage user data"
|
||||||
) $ do
|
) $ H.p $ H.form
|
||||||
H.p $ H.form
|
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <>
|
H.! HA.action ("/" <>
|
||||||
(fromString $ show $ linkURI $
|
fromString (show $ linkURI $
|
||||||
userManageDetailsSubmitLink (MT.userDetailsId userDetails)))
|
userManageDetailsSubmitLink (MT.userDetailsId userDetails)))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||||
H.legend $ H.toHtml $ translate "User details"
|
H.legend $ H.toHtml $ translate "User details"
|
||||||
|
@ -210,9 +208,9 @@ userManagePage l10n locale userDetails authOverviews =
|
||||||
H.! HA.type_ "email"
|
H.! HA.type_ "email"
|
||||||
H.! HA.required ""
|
H.! HA.required ""
|
||||||
H.! HA.value
|
H.! HA.value
|
||||||
(fromMaybe "" $ fromString <$> T.unpack <$>
|
(maybe "" (fromString . T.unpack)
|
||||||
MT.userDetailsEmail userDetails)
|
(MT.userDetailsEmail userDetails))
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
@ -222,24 +220,25 @@ userManagePage l10n locale userDetails authOverviews =
|
||||||
(\(MT.AuthOverview aoid comment method) -> H.form
|
(\(MT.AuthOverview aoid comment method) -> H.form
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <>
|
H.! HA.action ("/" <>
|
||||||
(fromString $ show $ linkURI $
|
fromString (show $ linkURI $
|
||||||
userManageAuthDeleteLink (MT.userDetailsId userDetails)))
|
userManageAuthDeleteLink (MT.userDetailsId userDetails)))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||||
H.legend $ H.toHtml $ comment <> " - " <> case method of
|
H.legend $ H.toHtml (comment <> " - " <> case method of
|
||||||
MT.PrimaryPass ->
|
MT.PrimaryPass ->
|
||||||
translate "Primary password"
|
translate "Primary password"
|
||||||
MT.SecondaryPass ->
|
MT.SecondaryPass ->
|
||||||
translate "Secondary password"
|
translate "Secondary password"
|
||||||
MT.ChallengeResponse ->
|
MT.ChallengeResponse ->
|
||||||
translate "Challenge response authentication"
|
translate "Challenge response authentication"
|
||||||
H.div H.! HA.class_ "form-group required" $ do
|
)
|
||||||
|
H.div H.! HA.class_ "form-group required" $
|
||||||
H.input
|
H.input
|
||||||
H.! HA.class_ "form-control"
|
H.! HA.class_ "form-control"
|
||||||
H.! HA.name "unId"
|
H.! HA.name "unId"
|
||||||
H.! HA.type_ "hidden"
|
H.! HA.type_ "hidden"
|
||||||
H.! HA.required ""
|
H.! HA.required ""
|
||||||
H.! HA.value (fromString $ show aoid)
|
H.! HA.value (fromString $ show aoid)
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
@ -249,7 +248,7 @@ userManagePage l10n locale userDetails authOverviews =
|
||||||
H.form
|
H.form
|
||||||
H.! HA.method "post"
|
H.! HA.method "post"
|
||||||
H.! HA.action ("/" <>
|
H.! HA.action ("/" <>
|
||||||
(fromString $ show $ linkURI $
|
fromString (show $ linkURI $
|
||||||
userManageAuthCreateLink (MT.userDetailsId userDetails)))
|
userManageAuthCreateLink (MT.userDetailsId userDetails)))
|
||||||
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do
|
||||||
H.legend $ H.toHtml $ translate "Authentication details"
|
H.legend $ H.toHtml $ translate "Authentication details"
|
||||||
|
@ -288,7 +287,7 @@ userManagePage l10n locale userDetails authOverviews =
|
||||||
H.option H.!
|
H.option H.!
|
||||||
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
|
HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $
|
||||||
H.toHtml $ translate "Primary password"
|
H.toHtml $ translate "Primary password"
|
||||||
H.div H.! HA.class_ "form-group optional" $ do
|
H.div H.! HA.class_ "form-group optional" $
|
||||||
H.button
|
H.button
|
||||||
H.! HA.class_ "btn btn-default"
|
H.! HA.class_ "btn btn-default"
|
||||||
H.! HA.type_ "submit"
|
H.! HA.type_ "submit"
|
||||||
|
|
Loading…
Reference in a new issue