new user creation possible

This commit is contained in:
nek0 2019-09-17 21:29:56 +02:00
parent 017484ff9d
commit 20a1a8e888
11 changed files with 179 additions and 15 deletions

View file

@ -21,10 +21,12 @@ executable matebeamter
other-modules: API other-modules: API
, Client , Client
, Util , Util
, Hash
, Types , Types
, Types.Page , Types.Page
, Types.Reader , Types.Reader
, Types.Views , Types.Views
, Types.Orphans
, Control , Control
, Control.Auth , Control.Auth
, Control.User , Control.User
@ -43,16 +45,21 @@ executable matebeamter
, servant-rawm , servant-rawm
, aeson , aeson
, blaze-html , blaze-html
, blaze-markup
, text , text
, bytestring , bytestring
, warp , warp
, wai , wai
, wai-logger , wai-logger
, http-client , http-client
, http-api-data
, mtl , mtl
, i18n , i18n
, cookie , cookie
, split , split
, random-bytestring
, base64-bytestring
, cryptonite
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View file

@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module API where module API where
@ -17,6 +18,10 @@ import Servant.HTML.Blaze
import Data.Proxy import Data.Proxy
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import Types import Types
@ -24,10 +29,14 @@ import Types
type UserAPI = type UserAPI =
Get '[HTML] UserSelectPage Get '[HTML] UserSelectPage
:<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage :<|> "user" :> Capture "id" Int :> Get '[HTML] UserOverviewPage
:<|> "user" :> "create" :> Get '[HTML] UserNewPage
:<|> "user" :> "create" :> ReqBody '[FormUrlEncoded] MT.UserSubmit :> Post '[HTML] UserSelectPage
:<|> "auth" :> Get '[HTML] AuthPage :<|> "auth" :> Get '[HTML] AuthPage
( userSelectLink :<|> ( userSelectLink :<|>
userOverviewLink :<|> userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
authLink authLink
) = allLinks (Proxy :: Proxy UserAPI) ) = allLinks (Proxy :: Proxy UserAPI)

View file

@ -2,24 +2,34 @@
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
module Control.User where module Control.User where
import Servant
import Servant.Client import Servant.Client
import Servant.Server
import Data.String (fromString)
import Data.Text.I18n import Data.Text.I18n
import Control.Monad (void)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
-- imports from mateamt -- imports from "mateamt"
import qualified "mateamt" API as MA
import qualified "mateamt" Types as MT
-- internal imports -- internal imports
import Types import Types
import Client import Client
import View import View
import Hash
import API
userSelectControl :: UserHandler UserSelectPage userSelectControl :: UserHandler UserSelectPage
userSelectControl = do userSelectControl = do
(ReadState l10n backend) <- ask (ReadState l10n backend _) <- ask
let loc = Locale "en" let loc = Locale "en"
euser <- liftIO $ runClientM euser <- liftIO $ runClientM
(userList (Nothing)) (userList (Nothing))
@ -30,6 +40,29 @@ userSelectControl = do
Left err -> Left err ->
error $ show 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 :: Int -> UserHandler UserOverviewPage
userOverviewControl uid = do userOverviewControl uid = do
error "Not yet implemented" error "Not yet implemented"

27
src/Hash.hs Normal file
View file

@ -0,0 +1,27 @@
module Hash where
import Crypto.KDF.PBKDF2
import Crypto.Hash.Algorithms (SHA3_512(..))
import qualified Data.Text as T
import Data.Text.Encoding
import Data.ByteString
import Data.ByteString.Random (random)
import qualified Data.ByteString.Base64 as B64
import Control.Monad.Reader (ask)
import Control.Monad.IO.Class (liftIO)
-- internal imports
import Types
hashPassword
:: T.Text
-> UserHandler T.Text
hashPassword passwd = do
(HashParams iter saltl outputl) <- rsHashParams <$> ask
salt <- liftIO $ random (fromIntegral saltl)
let hash = generate (prfHMAC SHA3_512) (Parameters iter outputl) (encodeUtf8 passwd) salt :: ByteString
return $ decodeUtf8 $ B64.encode hash

View file

@ -29,8 +29,9 @@ main = 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 manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams
} }
runSettings settings (userApp initState) runSettings settings (userApp initState)
@ -41,6 +42,8 @@ userApp initState = serveWithContext userApi (EmptyContext) $
(`runReaderT` initState) (`runReaderT` initState)
( userSelectControl ( userSelectControl
:<|> userOverviewControl :<|> userOverviewControl
:<|> userNewControl
:<|> userNewPostControl
:<|> authControl :<|> authControl
) )

View file

@ -5,3 +5,4 @@ module Types
import Types.Page as T import Types.Page as T
import Types.Reader as T import Types.Reader as T
import Types.Views as T import Types.Views as T
import Types.Orphans as T

17
src/Types/Orphans.hs Normal file
View file

@ -0,0 +1,17 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Types.Orphans where
import qualified "mateamt" Types as MT
import GHC.Generics
import Text.Blaze
import Servant.API
import Servant.HTML.Blaze
import Web.Internal.FormUrlEncoded
instance MimeUnrender HTML MT.UserSubmit
instance FromForm MT.UserSubmit

View file

@ -9,10 +9,26 @@ import Control.Monad.Reader (ReaderT)
import Data.Text.I18n import Data.Text.I18n
import Crypto.KDF.PBKDF2
import Crypto.Hash.Algorithms
data ReadState = ReadState data ReadState = ReadState
-- { rsManager :: Manager -- { rsManager :: Manager
{ rsL10n :: L10n { rsL10n :: L10n
, rsBackend :: ClientEnv , rsBackend :: ClientEnv
, rsHashParams :: HashParams
} }
type UserHandler = ReaderT ReadState Handler type UserHandler = ReaderT ReadState Handler
data HashParams = HashParams
{ hashIterations :: Int
, hashSaltLength :: Int
, hashOutputLength :: Int
}
recommendedHashParams = HashParams
{ hashIterations = 8000
, hashSaltLength = 23
, hashOutputLength = 512
}

View file

@ -4,6 +4,8 @@ import qualified Text.Blaze.Html5 as H
type UserSelectPage = H.Html type UserSelectPage = H.Html
type UserNewPage = H.Html
type UserOverviewPage = H.Html type UserOverviewPage = H.Html
type AuthPage = H.Html type AuthPage = H.Html

View file

@ -25,7 +25,7 @@ scaffold
-> 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 $ do
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" $ do

View file

@ -5,7 +5,7 @@ module View.User where
import Servant.Links import Servant.Links
import qualified Text.Blaze.Html5 as H hiding (style) import qualified Text.Blaze.Html5 as H hiding (style)
import qualified Text.Blaze.Html5.Attributes as H import qualified Text.Blaze.Html5.Attributes as HA
import Data.Text.I18n import Data.Text.I18n
@ -35,10 +35,11 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(translate "Home") (translate "Home")
) $ do ) $ do
mapM_ (\(MT.UserSummary uid ident _) -> do mapM_ (\(MT.UserSummary uid ident _) -> do
H.a H.! H.href (fromString $ show $ linkURI $ userOverviewLink uid) $ H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userOverviewLink uid)) $
H.toHtml ident H.toHtml ident
) uss ) uss
H.a H.! H.href ("#") $ H.toHtml $ translate "New user" H.a H.! HA.href ("/" <> (fromString $ show $ linkURI $ userNewLink)) $
H.toHtml $ translate "New user"
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
@ -56,24 +57,24 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
) $ 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, H.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.ul H.! H.class_ "product_list" $ H.ul H.! HA.class_ "product_list" $
mapM_ mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do (\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
H.li H.! H.class_ "product" H.!? H.li H.! HA.class_ "product" H.!?
(isJust avatarid (isJust avatarid
, productBgStyle (fromString $ show $ fromJust avatarid) , productBgStyle (fromString $ show $ fromJust avatarid)
) $ ) $
H.a H.! H.href ("#" <> fromString (show pid)) $ H.toHtml ident H.a H.! HA.href ("#" <> fromString (show pid)) $ H.toHtml ident
) )
pos pos
where where
translate = localize l10n locale . gettext translate = localize l10n locale . gettext
productBgStyle aid = H.style $ mconcat productBgStyle aid = HA.style $ mconcat
[ "background-image: url(#" <> aid <> ");" -- FILLME [ "background-image: url(#" <> aid <> ");" -- FILLME
, "backgronud-color: blue;" , "backgronud-color: blue;"
, "text-shadow:" , "text-shadow:"
@ -82,3 +83,51 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
, " 1px 0 1px black," , " 1px 0 1px black,"
, " 0 -1px 1px black;" , " 0 -1px 1px black;"
] ]
userNewPage
:: L10n
-> Locale
-> UserNewPage
userNewPage l10n locale = scaffold l10n locale (initPage $
(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"
where
translate = localize l10n locale . gettext