nek0/matebeamter
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

new user creation possible

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

7
matebeamter.cabal
View file

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

9
src/API.hs
View file

@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PackageImports #-}
module API where
@ -17,6 +18,10 @@ import Servant.HTML.Blaze
import Data.Proxy
-- imports from "mateamt"
import qualified "mateamt" Types as MT
-- internal imports
import Types
@ -24,10 +29,14 @@ import Types
type UserAPI =
Get '[HTML] UserSelectPage
:<|> "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
( userSelectLink :<|>
userOverviewLink :<|>
userNewLink :<|>
userNewPostLink :<|>
authLink
) = allLinks (Proxy :: Proxy UserAPI)

37
src/Control/User.hs
View file

@ -2,24 +2,34 @@
{-# 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
-- 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
(ReadState l10n backend _) <- ask
let loc = Locale "en"
euser <- liftIO $ runClientM
(userList (Nothing))
@ -30,6 +40,29 @@ userSelectControl = do
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"

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

7
src/Main.hs
View file

@ -29,8 +29,9 @@ main = do
let settings = setPort 3000 $ setLogger ilog defaultSettings
initState = ReadState
-- { rsManager = manager
{ rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
{ rsL10n = l10n
, rsBackend = mkClientEnv manager (BaseUrl Http "localhost" 8000 "")
, rsHashParams = recommendedHashParams
}
runSettings settings (userApp initState)
@ -41,6 +42,8 @@ userApp initState = serveWithContext userApi (EmptyContext) $
(`runReaderT` initState)
( userSelectControl
:<|> userOverviewControl
:<|> userNewControl
:<|> userNewPostControl
:<|> authControl
)

1
src/Types.hs
View file

@ -5,3 +5,4 @@ module Types
import Types.Page as T
import Types.Reader 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

20
src/Types/Reader.hs
View file

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

2
src/Types/Views.hs
View file

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

2
src/View/Scaffold.hs
View file

@ -25,7 +25,7 @@ scaffold
-> 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.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

65
src/View/User.hs
View file

@ -5,7 +5,7 @@ module View.User where
import Servant.Links
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
@ -35,10 +35,11 @@ userSelectPage l10n locale uss = scaffold l10n locale (initPage $
(translate "Home")
) $ 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
) 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
translate = localize l10n locale . gettext
@ -56,24 +57,24 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
) $ do
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") <>
": " <>
(formatMoney $ MT.userDetailsBalance ud)
-- TODO: Add currency symbol
H.ul H.! H.class_ "product_list" $
H.ul H.! HA.class_ "product_list" $
mapM_
(\(MT.ProductShortOverview pid ident _ _ _ avatarid) -> do
H.li H.! H.class_ "product" H.!?
H.li H.! HA.class_ "product" H.!?
(isJust 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
where
translate = localize l10n locale . gettext
productBgStyle aid = H.style $ mconcat
productBgStyle aid = HA.style $ mconcat
[ "background-image: url(#" <> aid <> ");" -- FILLME
, "backgronud-color: blue;"
, "text-shadow:"
@ -82,3 +83,51 @@ userOverviewPage l10n locale ud pos = scaffold l10n locale (initPage $
, " 1px 0 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