From 20a1a8e888671699812713a7acf9faf59ea7a4f5 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 17 Sep 2019 21:29:56 +0200 Subject: [PATCH] new user creation possible --- matebeamter.cabal | 7 +++++ src/API.hs | 9 ++++++ src/Control/User.hs | 37 +++++++++++++++++++++++-- src/Hash.hs | 27 ++++++++++++++++++ src/Main.hs | 7 +++-- src/Types.hs | 1 + src/Types/Orphans.hs | 17 ++++++++++++ src/Types/Reader.hs | 20 ++++++++++++-- src/Types/Views.hs | 2 ++ src/View/Scaffold.hs | 2 +- src/View/User.hs | 65 ++++++++++++++++++++++++++++++++++++++------ 11 files changed, 179 insertions(+), 15 deletions(-) create mode 100644 src/Hash.hs create mode 100644 src/Types/Orphans.hs diff --git a/matebeamter.cabal b/matebeamter.cabal index 5c34a5e..b6dc189 100644 --- a/matebeamter.cabal +++ b/matebeamter.cabal @@ -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 diff --git a/src/API.hs b/src/API.hs index 1a256b4..b64efae 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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) diff --git a/src/Control/User.hs b/src/Control/User.hs index 0bfd0ae..7623b4d 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -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" diff --git a/src/Hash.hs b/src/Hash.hs new file mode 100644 index 0000000..dbf0d25 --- /dev/null +++ b/src/Hash.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 4a6b2af..630879c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 ) diff --git a/src/Types.hs b/src/Types.hs index 9f99c3f..2446163 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Orphans.hs b/src/Types/Orphans.hs new file mode 100644 index 0000000..ca1638c --- /dev/null +++ b/src/Types/Orphans.hs @@ -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 diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs index bd4f82c..05bc257 100644 --- a/src/Types/Reader.hs +++ b/src/Types/Reader.hs @@ -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 + } diff --git a/src/Types/Views.hs b/src/Types/Views.hs index ed5a043..2cbe87f 100644 --- a/src/Types/Views.hs +++ b/src/Types/Views.hs @@ -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 diff --git a/src/View/Scaffold.hs b/src/View/Scaffold.hs index a3c30cc..005f553 100644 --- a/src/View/Scaffold.hs +++ b/src/View/Scaffold.hs @@ -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 diff --git a/src/View/User.hs b/src/View/User.hs index 7c527a0..a5478a4 100644 --- a/src/View/User.hs +++ b/src/View/User.hs @@ -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