From b29daaf841205e729d54071b1471e48e29961f0e Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 16 Oct 2019 18:07:12 +0200 Subject: [PATCH] linted --- src/API.hs | 7 +- src/Client.hs | 104 +++++++++++--- src/ClientAuth.hs | 2 +- src/Control/Auth.hs | 14 +- src/Control/User.hs | 79 ++++++----- src/Hash.hs | 6 +- src/Main.hs | 10 +- src/Model/Auth.hs | 3 - src/Model/User.hs | 7 - src/Types/Orphans.hs | 10 +- src/Types/Page.hs | 5 +- src/Util.hs | 14 +- src/View/Auth.hs | 7 +- src/View/Scaffold.hs | 6 +- src/View/User.hs | 317 +++++++++++++++++++++---------------------- 15 files changed, 320 insertions(+), 271 deletions(-) delete mode 100644 src/Model/Auth.hs delete mode 100644 src/Model/User.hs diff --git a/src/API.hs b/src/API.hs index 8e8be80..26bc594 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,10 +1,8 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PackageImports #-} @@ -13,7 +11,7 @@ module API where import Servant.API import Servant.Links -import Servant.RawM +-- import Servant.RawM import Servant.HTML.Blaze import Data.Proxy @@ -57,7 +55,6 @@ type UserAPI = :> ReqBody '[FormUrlEncoded] AuthReturn :> Post '[HTML] UserSelectPage :<|> "auth" :> "logout" - -- :> ReqBody '[FormUrlEncoded] () :> Post '[HTML] UserOverviewPage ) diff --git a/src/Client.hs b/src/Client.hs index b6bec4b..d32d0c1 100644 --- a/src/Client.hs +++ b/src/Client.hs @@ -1,35 +1,101 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PackageImports #-} module Client where import Servant import Servant.Client - -import Network.HTTP.Client hiding (Proxy) - -import Control.Monad.IO.Class (liftIO) +import Servant.Client.Core.Auth +import Servant.Client.Core.Request -- imports from mateamt -import qualified "mateamt" API as MT -import qualified "mateamt" Types as MT +import qualified "mateamt" API as MA +import qualified "mateamt" Types as MT -- internal imports -import Types - -mateApi :: Proxy MT.MateAPI +mateApi :: Proxy MA.MateAPI 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 :<|> authSend :<|> authLogout :<|> diff --git a/src/ClientAuth.hs b/src/ClientAuth.hs index 9420297..abf678b 100644 --- a/src/ClientAuth.hs +++ b/src/ClientAuth.hs @@ -9,4 +9,4 @@ import Servant.Client.Core type instance AuthClientData (AuthProtect "header-auth") = String authenticateReq :: String -> Request -> Request -authenticateReq s req = addHeader "Authentication" s req +authenticateReq = addHeader "Authentication" diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 46604c8..c68f46b 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -49,7 +49,7 @@ authControl mcookie mDestination = do mAuthUser = lookup "x-auth-user" =<< mParsedCookie mToken = lookup "x-token" =<< mParsedCookie case (mAuthUser, mToken) of - (Just authUser, Just _) -> do + (Just authUser, Just _) -> throwError $ case mDestination of Just destination -> err303 @@ -74,7 +74,7 @@ authControl mcookie mDestination = do , MT.SecondaryPass ] eAuthInfos <- zip passes <$> - (liftIO $ mapM + liftIO (mapM (\req -> runClientM (authGet req) backend @@ -85,7 +85,7 @@ authControl mcookie mDestination = do then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $ unzip eAuthInfos) else throwError $ err400 - { errBody = fromString $ show $ lefts $ snd $ unzip eAuthInfos + { errBody = fromString $ show $ lefts $ map snd eAuthInfos } (Nothing, _) -> error "Error handling not yet implemented properly." @@ -105,10 +105,10 @@ authControl mcookie mDestination = do ticketHeaders = map (\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) -> "x-ticket-"<> fromString (show $ fromEnum method) <>"=" <> - (fromString $ T.unpack ticket) <> ";Path=/") + fromString (T.unpack ticket) <> ";Path=/") tupAuthInfos return $ - addHeader (ticketHeaders !! 0) $ + addHeader (head ticketHeaders) $ addHeader (ticketHeaders !! 1) $ authPage l10n loc mDestination @@ -177,8 +177,8 @@ authLogoutControl authLogoutControl mcookie = do (ReadState _ backend _) <- ask let mParsedCookie = fmap parseCookieText mcookie - token = T.unpack $ fromMaybe "secret" $ - ((lookup "x-token") =<< mParsedCookie) + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) eReturn <- liftIO $ runClientM (authLogout (mkAuthenticatedRequest token authenticateReq)) backend diff --git a/src/Control/User.hs b/src/Control/User.hs index f6f95b7..9e116ee 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -7,7 +7,6 @@ module Control.User where import Servant import Servant.Client import Servant.Client.Core.Auth -import Servant.Server import Data.String (fromString) @@ -17,15 +16,14 @@ import Data.Text.I18n import Data.Maybe (fromMaybe) import Data.Either.Combinators (leftToMaybe) -import Control.Monad (void, when) -import Control.Monad.Reader (ask) +import Control.Monad (void) +import Control.Monad.Reader (ask, asks) import Control.Monad.IO.Class (liftIO) import Network.HTTP.Types.Status -- imports from "mateamt" -import qualified "mateamt" API as MA import qualified "mateamt" Types as MT -- internal imports @@ -44,7 +42,7 @@ userSelectControl mcookie = do let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) euser <- liftIO $ runClientM - (userList (Nothing)) + (userList Nothing) backend case euser of Right uss -> @@ -54,7 +52,7 @@ userSelectControl mcookie = do userNewControl :: Maybe T.Text -> UserHandler UserNewPage userNewControl mcookie = do - (ReadState l10n backend _) <- ask + (ReadState l10n _ _) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) return $ userNewPage l10n loc @@ -63,8 +61,8 @@ userNewPostControl :: Maybe T.Text -> MT.UserSubmit -> UserHandler UserSelectPage -userNewPostControl _ us@(MT.UserSubmit ident email pass) = do - backend <- rsBackend <$> ask +userNewPostControl _ us@(MT.UserSubmit _ _ pass) = do + backend <- asks rsBackend hashedPass <- hashPassword pass void $ liftIO $ runClientM (userNew $us @@ -89,7 +87,7 @@ userOverviewControl mcookie uid mRefine = do (lookup "x-auth-user" =<< mParsedCookie) mMethod = T.unpack <$> (lookup "x-method" =<< mParsedCookie) - euser <- liftIO $ do + euser <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend @@ -129,7 +127,7 @@ userOverviewControl mcookie uid mRefine = do } (Left uerr, Left perr) -> throwError $ err500 - { errBody = (fromString $ show uerr) <> " " <> (fromString $ show perr) + { errBody = fromString (show uerr) <> " " <> fromString (show perr) } userManageControl @@ -141,15 +139,15 @@ userManageControl mcookie uid = do let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) mParsedCookie = fmap parseCookieText mcookie - token = T.unpack $ fromMaybe "secret" $ - ((lookup "x-token") =<< mParsedCookie) + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> - ((lookup "x-auth-user") =<< mParsedCookie) - eUserDetails <- liftIO $ do + (lookup "x-auth-user" =<< mParsedCookie) + eUserDetails <- liftIO $ runClientM (userGet (mkAuthenticatedRequest token authenticateReq)) backend - eAuthOverviews <- liftIO $ do + eAuthOverviews <- liftIO $ runClientM (authManageList (mkAuthenticatedRequest token authenticateReq)) backend @@ -165,15 +163,18 @@ userManageControl mcookie uid = do (Just $ userManageLink uid) [leftToMaybe (fst err), leftToMaybe (snd err)] +userManageDetailsSubmitControl + :: Maybe T.Text + -> Int + -> MT.UserDetailsSubmit + -> UserHandler UserOverviewPage userManageDetailsSubmitControl mcookie uid uds = do - (ReadState l10n backend _) <- ask - let loc = Locale - (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - mParsedCookie = fmap parseCookieText mcookie - token = T.unpack $ fromMaybe "secret" $ - ((lookup "x-token") =<< mParsedCookie) + (ReadState _ backend _) <- ask + let mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> - ((lookup "x-auth-user") =<< mParsedCookie) + (lookup "x-auth-user" =<< mParsedCookie) eReturn <- liftIO $ runClientM (userUpdate (mkAuthenticatedRequest token authenticateReq) uds) backend @@ -182,15 +183,18 @@ userManageDetailsSubmitControl mcookie uid uds = do Left 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 - (ReadState l10n backend _) <- ask - let loc = Locale - (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - mParsedCookie = fmap parseCookieText mcookie - token = T.unpack $ fromMaybe "secret" $ - ((lookup "x-token") =<< mParsedCookie) + (ReadState _ backend _) <- ask + let mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> - ((lookup "x-auth-user") =<< mParsedCookie) + (lookup "x-auth-user" =<< mParsedCookie) hashedPass <- hashPassword pass eReturn <- liftIO $ runClientM (authManageNewAuth @@ -203,15 +207,18 @@ userManageAuthCreateControl mcookie uid (AuthSubmitReturn comment pass method) = Left err -> handleErrors (fmap read mAuthUser) (Just $ userManageLink uid) [Just err] +userManageAuthDeleteControl + :: Maybe T.Text + -> Int + -> AuthDetailId + -> UserHandler UserOverviewPage userManageAuthDeleteControl mcookie uid (AuthDetailId adid) = do - (ReadState l10n backend _) <- ask - let loc = Locale - (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) - mParsedCookie = fmap parseCookieText mcookie - token = T.unpack $ fromMaybe "secret" $ - ((lookup "x-token") =<< mParsedCookie) + (ReadState _ backend _) <- ask + let mParsedCookie = fmap parseCookieText mcookie + token = T.unpack $ fromMaybe "secret" + (lookup "x-token" =<< mParsedCookie) mAuthUser = T.unpack <$> - ((lookup "x-auth-user") =<< mParsedCookie) + (lookup "x-auth-user" =<< mParsedCookie) eReturn <- liftIO $ runClientM (authManageDeleteAuth (mkAuthenticatedRequest token authenticateReq) adid) backend diff --git a/src/Hash.hs b/src/Hash.hs index a79507b..d58958b 100644 --- a/src/Hash.hs +++ b/src/Hash.hs @@ -10,7 +10,7 @@ import Data.ByteString import Data.ByteString.Random (random) import qualified Data.ByteString.Base64 as B64 -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) import Control.Monad.IO.Class (liftIO) -- internal imports @@ -21,8 +21,8 @@ hashPassword :: T.Text -> UserHandler T.Text hashPassword passwd = do - (HashParams iter _ outputl) <- rsHashParams <$> ask - let saltl = 0 + (HashParams iter _ outputl) <- asks rsHashParams + let saltl = 0 :: Int salt <- liftIO $ random (fromIntegral saltl) let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString return $ decodeUtf8 $ B64.encode hash diff --git a/src/Main.hs b/src/Main.hs index a186ea3..6973a24 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,6 @@ module Main where import Servant -import Servant.Server import Servant.Client import Network.Wai.Handler.Warp @@ -13,32 +12,31 @@ import Network.HTTP.Client hiding (Proxy) import Control.Monad.Reader -import Data.Text.I18n import Data.Text.I18n.Po -- internal imports import API import Types -import View import Control main :: IO () main = do - manager <- newManager defaultManagerSettings + mngr <- newManager defaultManagerSettings (l10n, _) <- getL10n "./locales" withStdoutLogger $ \ilog -> do let settings = setPort 3000 $ setLogger ilog defaultSettings initState = ReadState -- { rsManager = manager { rsL10n = l10n - , rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "") + , rsBackend = mkClientEnv mngr (BaseUrl Http "localhost" 8000 "") , rsHashParams = recommendedHashParams } runSettings settings (userApp initState) -userApp initState = serveWithContext userApi (EmptyContext) $ +userApp :: ReadState -> Application +userApp initState = serveWithContext userApi EmptyContext $ hoistServerWithContext userApi Proxy diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs deleted file mode 100644 index 117f81e..0000000 --- a/src/Model/Auth.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Model.Auth where - - diff --git a/src/Model/User.hs b/src/Model/User.hs deleted file mode 100644 index 0ea70af..0000000 --- a/src/Model/User.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -module Model.User where - -import qualified "mateamt" Types as MT - - diff --git a/src/Types/Orphans.hs b/src/Types/Orphans.hs index c8ba688..2df05fd 100644 --- a/src/Types/Orphans.hs +++ b/src/Types/Orphans.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-missing-methods #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -5,14 +7,6 @@ module Types.Orphans where 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.HTML.Blaze import Web.Internal.FormUrlEncoded diff --git a/src/Types/Page.hs b/src/Types/Page.hs index 4e3401b..b9a0f45 100644 --- a/src/Types/Page.hs +++ b/src/Types/Page.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Types.Page where import qualified Data.Text as T @@ -44,9 +43,9 @@ template template (Page title favicon meta style) content = H.docTypeHtml $ do H.head $ do - H.title $ H.toHtml $ title + H.title $ H.toHtml title meta favicon style - H.body $ + H.body content diff --git a/src/Util.hs b/src/Util.hs index 4ebed29..cfe3efe 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,12 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE LambdaCase #-} module Util where import Servant hiding (addHeader) import Servant.Client import Servant.Client.Core.Request -import Servant.Client.Core.Request (addHeader) import qualified Data.Text as T import Data.Text.Lazy.Encoding @@ -58,7 +58,7 @@ redirect303 redirect303 link = err303 { errHeaders = - [ ("Location", "/" <> (fromString $ show $ linkURI link)) + [ ("Location", "/" <> fromString (show $ linkURI link)) ] } @@ -77,7 +77,7 @@ handleErrors -> UserHandler UserOverviewPage handleErrors mAuthUser mLink merrs = do codes <- mapM - (\eerr -> case eerr of + (\case Just (FailureResponse _ resp) -> return $ statusCode (responseStatusCode resp) Just err -> @@ -88,7 +88,7 @@ handleErrors mAuthUser mLink merrs = do return 200 ) merrs - if (any (== 401) codes) + if 401 `elem` codes then redirectOverAuth mAuthUser mLink Nothing else @@ -99,14 +99,14 @@ handleErrors mAuthUser mLink merrs = do redirectOverAuth :: Maybe Int -> Maybe Link - -> Maybe (MT.ProductRefine) + -> Maybe MT.ProductRefine -> UserHandler UserOverviewPage redirectOverAuth muid mLink mRefine = do let redirectHeaders = errHeaders $ redirect303 (authLink (Just $ "/" <> fromString (show $ linkURI (case (mLink, muid) of (Just link, _) -> link - (Nothing, Just uid) -> userOverviewLink uid Nothing + (Nothing, Just uid) -> userOverviewLink uid mRefine _ -> userSelectLink )))) throwError @@ -114,7 +114,7 @@ redirectOverAuth muid mLink mRefine = do { errHeaders = redirectHeaders ++ (case muid of Just uid -> [ ( "Set-Cookie" - , "x-auth-user=" <> (fromString $ show uid) <> "; Path=/" + , "x-auth-user=" <> fromString (show uid) <> "; Path=/" ) ] Nothing -> diff --git a/src/View/Auth.hs b/src/View/Auth.hs index 11d6470..8b7667c 100644 --- a/src/View/Auth.hs +++ b/src/View/Auth.hs @@ -36,10 +36,9 @@ authPage l10n locale mDestination = scaffold " - " <> translate "Authentication" ) - $ do - H.p $ H.form + $ H.p $ H.form H.! HA.method "post" - H.! HA.action ("/" <> (fromString $ show $ linkURI $ + H.! HA.action ("/" <> fromString (show $ linkURI $ authPostLink mDestination)) H.! HA.enctype "application/x-www-form-urlencoded" $ 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.required "" H.! HA.value "" - H.div H.! HA.class_ "form-group optional" $ do + H.div H.! HA.class_ "form-group optional" $ H.button H.! HA.class_ "btn btn-default" H.! HA.type_ "submit" diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index 005f553..e0fc054 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -24,9 +24,9 @@ scaffold -> H.Html -> H.Html scaffold l10n locale page content = template page $ do - H.header $ H.nav $ H.ul $ do - H.li $ H.a H.! H.href ("/" <> (fromString $ show $ linkURI $ userSelectLink)) $ + H.header $ H.nav $ H.ul $ + H.li $ H.a H.! H.href ("/" <> fromString (show $ linkURI userSelectLink)) $ H.toHtml $ localize l10n locale $ gettext "Home" H.hr - H.div H.! H.id "main" H.! H.role "main" $ do + H.div H.! H.id "main" H.! H.role "main" $ content diff --git a/src/View/User.hs b/src/View/User.hs index 42c6c88..d67a0da 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -13,7 +13,7 @@ import Data.Text.I18n import Data.String (fromString) -import Data.Maybe (isJust, fromJust, fromMaybe) +import Data.Maybe (isJust, fromJust) -- imports from mateamt @@ -32,16 +32,16 @@ userSelectPage -> [MT.UserSummary] -> UserSelectPage userSelectPage l10n locale uss = scaffold l10n locale (initPage $ - (translate "Matebeamter") <> + translate "Matebeamter" <> " - " <> - (translate "Home") + translate "Home" ) $ do - mapM_ (\(MT.UserSummary uid ident _) -> do - H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ + mapM_ (\(MT.UserSummary uid ident _) -> + H.a H.! HA.href ("/" <> fromString (show $ linkURI $ userOverviewLink uid Nothing)) $ H.toHtml ident ) uss - H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $ + H.a H.! HA.href ("/" <> fromString (show $ linkURI userNewLink)) $ H.toHtml $ translate "New user" where translate = localize l10n locale . gettext @@ -54,23 +54,23 @@ userOverviewPage -> [MT.ProductShortOverview] -> UserOverviewPage 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 ") <> - (MT.userDetailsIdent ud) + localize l10n locale (gettext "User Menu for ") <> + MT.userDetailsIdent ud ) $ 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 $ - (translate "Your current balance is") <> + translate "Your current balance is" <> ": " <> - (formatMoney $ MT.userDetailsBalance ud) + formatMoney (MT.userDetailsBalance ud) -- TODO: Add currency symbol H.p $ H.form H.! HA.method "post" - H.! HA.action ("/" <> (fromString $ show $ linkURI $ authLogoutLink)) - H.! HA.enctype "application/x-www-form-urlencoded" $ do - H.div H.! HA.class_ "form-group optional" $ do + H.! HA.action ("/" <> fromString (show $ linkURI authLogoutLink)) + H.! HA.enctype "application/x-www-form-urlencoded" $ + H.div H.! HA.class_ "form-group optional" $ H.button H.! HA.class_ "btn btn-default" H.! HA.type_ "submit" @@ -92,7 +92,7 @@ userSettingsPointer -> Int -> H.Html 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" where translate = localize l10n locale . gettext @@ -104,7 +104,7 @@ productList pos = H.p $ H.ul H.! HA.class_ "product_list" $ mapM_ - (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do + (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> H.li H.! HA.class_ "product" H.!? (isJust avatarid , productBgStyle (fromString $ show $ fromJust avatarid) @@ -129,46 +129,45 @@ userNewPage -> Locale -> UserNewPage userNewPage l10n locale = scaffold l10n locale (initPage $ - (translate "Matebeamter") <> + translate "Matebeamter" <> " - " <> - (translate "Create new user") - ) $ do - H.p $ H.form - H.! HA.method "post" - H.! HA.action ("/" <> (fromString $ show $ linkURI $ userNewPostLink)) - H.! HA.enctype "application/x-www-form-urlencoded" $ do - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "username" $ H.toHtml $ translate "Username" - H.input - H.! HA.id "username" - H.! HA.class_ "form-control" - H.! HA.name "userSubmitIdent" - H.! HA.type_ "text" - H.! HA.required "" - H.! HA.value "" - H.div H.! HA.class_ "form-group optional" $ do - H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" - H.input - H.! HA.id "useremail" - H.! HA.class_ "form-control" - H.! HA.name "userSubmitEmail" - H.! HA.type_ "email" - H.! HA.required "" - H.! HA.value "" - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password" - H.input - H.! HA.id "userpass" - H.! HA.class_ "form-control" - H.! HA.name "userSubmitPassHash" - H.! HA.type_ "password" - H.! HA.required "" - H.! HA.value "" - H.div H.! HA.class_ "form-group optional" $ do - H.button - H.! HA.class_ "btn btn-default" - H.! HA.type_ "submit" - $ H.toHtml $ translate "Submit" + translate "Create new user" + ) $ H.p $ H.form + H.! HA.method "post" + H.! HA.action ("/" <> fromString (show $ linkURI userNewPostLink)) + H.! HA.enctype "application/x-www-form-urlencoded" $ do + H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "username" $ H.toHtml $ translate "Username" + H.input + H.! HA.id "username" + H.! HA.class_ "form-control" + H.! HA.name "userSubmitIdent" + H.! HA.type_ "text" + H.! HA.required "" + H.! HA.value "" + H.div H.! HA.class_ "form-group optional" $ do + H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" + H.input + H.! HA.id "useremail" + H.! HA.class_ "form-control" + H.! HA.name "userSubmitEmail" + H.! HA.type_ "email" + H.! HA.required "" + H.! HA.value "" + H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "userpass" $ H.toHtml $ translate "Password" + H.input + H.! HA.id "userpass" + H.! HA.class_ "form-control" + H.! HA.name "userSubmitPassHash" + H.! HA.type_ "password" + H.! HA.required "" + H.! HA.value "" + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Submit" where translate = localize l10n locale . gettext @@ -180,118 +179,118 @@ userManagePage -> UserManagePage userManagePage l10n locale userDetails authOverviews = scaffold l10n locale (initPage $ - (translate "Matebeamter") <> + translate "Matebeamter" <> " - " <> - (translate "Manage user data") - ) $ do - H.p $ H.form - H.! HA.method "post" - H.! HA.action ("/" <> - (fromString $ show $ linkURI $ - userManageDetailsSubmitLink (MT.userDetailsId userDetails))) - H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do - H.legend $ H.toHtml $ translate "User details" - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "username" $ H.toHtml $ translate "Username" - H.input - H.! HA.id "username" - H.! HA.class_ "form-control" - H.! HA.name "userDetailsSubmitIdent" - H.! HA.type_ "text" - H.! HA.required "" - H.! HA.value - (fromString $ T.unpack $ MT.userDetailsIdent userDetails) - H.div H.! HA.class_ "form-group optional" $ do - H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" - H.input - H.! HA.id "useremail" - H.! HA.class_ "form-control" - H.! HA.name "userDetailsSubmitEmail" - H.! HA.type_ "email" - H.! HA.required "" - H.! HA.value - (fromMaybe "" $ fromString <$> T.unpack <$> - MT.userDetailsEmail userDetails) - H.div H.! HA.class_ "form-group optional" $ do - H.button - H.! HA.class_ "btn btn-default" - H.! HA.type_ "submit" - $ H.toHtml $ translate "Submit" - H.p $ do - mapM_ - (\(MT.AuthOverview aoid comment method) -> H.form + translate "Manage user data" + ) $ H.p $ H.form + H.! HA.method "post" + H.! HA.action ("/" <> + fromString (show $ linkURI $ + userManageDetailsSubmitLink (MT.userDetailsId userDetails))) + H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do + H.legend $ H.toHtml $ translate "User details" + H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "username" $ H.toHtml $ translate "Username" + H.input + H.! HA.id "username" + H.! HA.class_ "form-control" + H.! HA.name "userDetailsSubmitIdent" + H.! HA.type_ "text" + H.! HA.required "" + H.! HA.value + (fromString $ T.unpack $ MT.userDetailsIdent userDetails) + H.div H.! HA.class_ "form-group optional" $ do + H.label H.! HA.for "useremail" $ H.toHtml $ translate "Email" + H.input + H.! HA.id "useremail" + H.! HA.class_ "form-control" + H.! HA.name "userDetailsSubmitEmail" + H.! HA.type_ "email" + H.! HA.required "" + H.! HA.value + (maybe "" (fromString . T.unpack) + (MT.userDetailsEmail userDetails)) + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Submit" + H.p $ do + mapM_ + (\(MT.AuthOverview aoid comment method) -> H.form + H.! HA.method "post" + H.! HA.action ("/" <> + fromString (show $ linkURI $ + userManageAuthDeleteLink (MT.userDetailsId userDetails))) + H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do + H.legend $ H.toHtml (comment <> " - " <> case method of + MT.PrimaryPass -> + translate "Primary password" + MT.SecondaryPass -> + translate "Secondary password" + MT.ChallengeResponse -> + translate "Challenge response authentication" + ) + H.div H.! HA.class_ "form-group required" $ + H.input + H.! HA.class_ "form-control" + H.! HA.name "unId" + H.! HA.type_ "hidden" + H.! HA.required "" + H.! HA.value (fromString $ show aoid) + H.div H.! HA.class_ "form-group optional" $ + H.button + H.! HA.class_ "btn btn-default" + H.! HA.type_ "submit" + $ H.toHtml $ translate "Delete" + ) + authOverviews + H.form H.! HA.method "post" H.! HA.action ("/" <> - (fromString $ show $ linkURI $ - userManageAuthDeleteLink (MT.userDetailsId userDetails))) + fromString (show $ linkURI $ + userManageAuthCreateLink (MT.userDetailsId userDetails))) H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do - H.legend $ H.toHtml $ comment <> " - " <> case method of - MT.PrimaryPass -> - translate "Primary password" - MT.SecondaryPass -> - translate "Secondary password" - MT.ChallengeResponse -> - translate "Challenge response authentication" + H.legend $ H.toHtml $ translate "Authentication details" H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "comment" $ H.toHtml $ + translate "Comment" H.input - H.! HA.class_ "form-control" - H.! HA.name "unId" - H.! HA.type_ "hidden" + H.! HA.id "comment" + H.! HA.class_ "form_control" + H.! HA.name "authSubmitReturnComment" + H.! HA.type_ "text" H.! HA.required "" - H.! HA.value (fromString $ show aoid) - H.div H.! HA.class_ "form-group optional" $ do + H.! HA.value "" + H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "password" $ H.toHtml $ + translate "Password" + H.input + H.! HA.id "password" + H.! HA.class_ "form_control" + H.! HA.name "authSubmitReturnPass" + H.! HA.type_ "password" + H.! HA.required "" + H.! HA.value "" + H.div H.! HA.class_ "form-group required" $ do + H.label H.! HA.for "method" $ H.toHtml $ + translate "Authentication Method" + H.select + H.! HA.id "method" + H.! HA.class_ "form-control" + H.! HA.name "authSubmitReturnMethod" + H.! HA.required "" + H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do + H.option H.! + HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ + H.toHtml $ translate "Secondary password" + H.option H.! + HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $ + H.toHtml $ translate "Primary password" + H.div H.! HA.class_ "form-group optional" $ H.button H.! HA.class_ "btn btn-default" H.! HA.type_ "submit" - $ H.toHtml $ translate "Delete" - ) - authOverviews - H.form - H.! HA.method "post" - H.! HA.action ("/" <> - (fromString $ show $ linkURI $ - userManageAuthCreateLink (MT.userDetailsId userDetails))) - H.! HA.enctype "application/x-www-form-urlencoded" $ H.fieldset $ do - H.legend $ H.toHtml $ translate "Authentication details" - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "comment" $ H.toHtml $ - translate "Comment" - H.input - H.! HA.id "comment" - H.! HA.class_ "form_control" - H.! HA.name "authSubmitReturnComment" - H.! HA.type_ "text" - H.! HA.required "" - H.! HA.value "" - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "password" $ H.toHtml $ - translate "Password" - H.input - H.! HA.id "password" - H.! HA.class_ "form_control" - H.! HA.name "authSubmitReturnPass" - H.! HA.type_ "password" - H.! HA.required "" - H.! HA.value "" - H.div H.! HA.class_ "form-group required" $ do - H.label H.! HA.for "method" $ H.toHtml $ - translate "Authentication Method" - H.select - H.! HA.id "method" - H.! HA.class_ "form-control" - H.! HA.name "authSubmitReturnMethod" - H.! HA.required "" - H.! HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ do - H.option H.! - HA.value (fromString $ show $ fromEnum MT.SecondaryPass) $ - H.toHtml $ translate "Secondary password" - H.option H.! - HA.value (fromString $ show $ fromEnum MT.PrimaryPass) $ - H.toHtml $ translate "Primary password" - H.div H.! HA.class_ "form-group optional" $ do - H.button - H.! HA.class_ "btn btn-default" - H.! HA.type_ "submit" - $ H.toHtml $ translate "Submit" + $ H.toHtml $ translate "Submit" where translate = localize l10n locale . gettext