new user creation possible

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

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)

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"

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

src/Main.hs

@@ -31,6 +31,7 @@ main = do
           -- { rsManager = manager
           { 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
     )
 

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

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

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
+  , rsHashParams :: HashParams
   }
 
 type UserHandler = ReaderT ReadState Handler
+
+data HashParams = HashParams
+  { hashIterations   :: Int
+  , hashSaltLength   :: Int
+  , hashOutputLength :: Int
+  }
+
+recommendedHashParams = HashParams
+  { hashIterations   = 8000
+  , hashSaltLength   = 23
+  , hashOutputLength = 512
+  }

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

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

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