implement auth on web

package.yaml

@@ -30,6 +30,7 @@ dependencies:
 - cookie
 - data-has
 - digestive-functors
+- digestive-functors-scotty
 - exceptions
 - hedis
 - http-types

src/Adapter/HTTP/Web/Auth.hs

@@ -1,17 +1,22 @@
 module Adapter.HTTP.Web.Auth where
 
-import           Adapter.HTTP.API.Auth          ( authForm )
+import           Adapter.HTTP.Common
 import           Adapter.HTTP.Web.Common
+import           Control.Arrow                  ( left )
 import           Control.Monad.Reader           ( MonadIO
                                                 , lift
                                                 )
-import           Data.Text                      ( Text )
+import           Data.Text                      ( Text
+                                                , pack
+                                                )
 import           Domain.Auth
 import           Katip
 import qualified Text.Blaze.Html5              as H
 import           Text.Blaze.Html5               ( (!) )
 import qualified Text.Blaze.Html5.Attributes   as A
 import qualified Text.Digestive                as DF
+import           Text.Digestive.Form            ( (.:) )
+import           Text.Digestive.Scotty
 import           Web.Scotty.Trans
 
 
@@ -31,7 +36,7 @@ routes = do
     view <- DF.getForm "auth" authForm
     renderHtml $ registerPage view []
   post "/auth/register" $ do
-    (view, mAuth) <- _ "auth" authForm
+    (view, mAuth) <- runForm "auth" authForm
     case mAuth of
       Nothing   -> renderHtml $ registerPage view []
       Just auth -> do
@@ -55,7 +60,7 @@ routes = do
   post "/auth/login" $ undefined
 
   get "/users" $ do
-    userId <- reqCurrentUserId
+    userId <- Adapter.HTTP.Web.Common.reqCurrentUserId -- TODO
     mEmail <- lift $ getUser userId
     case mEmail of
       Nothing    -> raise $ stringError "Should not happen: email is not found"
@@ -74,3 +79,11 @@ verifyEmailPage message = mainLayout "Email verification" $ do
 
 registerPage :: DF.View [Text] -> [Text] -> H.Html
 registerPage = undefined
+
+authForm :: (Monad m) => DF.Form [Text] m Auth
+authForm = Auth <$> "email" .: emailForm <*> "password" .: passwordForm
+ where
+  emailForm    = DF.validate (toResult . asText . mkEmail) (DF.text Nothing)
+  passwordForm = DF.validate (toResult . asText . mkPassword) (DF.text Nothing)
+  asText :: (Show e) => Either [e] d -> Either [Text] d
+  asText = left (pack . show <$>)

src/Domain/Auth.hs

@@ -5,9 +5,11 @@ module Domain.Auth
     Auth(..)
   , Email
   , mkEmail
+  , mkEmail'
   , rawEmail
   , Password
   , mkPassword
+  , mkPassword'
   , rawPassword
   , UserId
   , VerificationCode
@@ -66,6 +68,12 @@ mkEmail = validate Email
       [r|^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,64}$|]
       EmailValidationErrInvalidEmail
   ]
+mkEmail' :: Text -> Either [Text] Email
+mkEmail' = validate Email
+  [ regexMatches
+      [r|^[A-Z0-9a-z._%+-]+@[A-Za-z0-9.-]+\.[A-Za-z]{2,64}$|]
+      "EmailValidationErrInvalidEmail"
+  ]
 
 newtype Password
   = Password { passwordRaw :: Text }
@@ -79,6 +87,13 @@ mkPassword = validate Password
   , regexMatches [r|[a-z]|] PasswordValidationErrMustContainLowerCase
   , lengthBetween 5 50 PasswordValidationErrLength
   ]
+mkPassword' :: Text -> Either [Text] Password
+mkPassword' = validate Password
+  [ regexMatches [r|[0-9]|] "PasswordValidationErrMustContainNumber"
+  , regexMatches [r|[A-Z]|] "PasswordValidationErrMustContainUpperCase"
+  , regexMatches [r|[a-z]|] "PasswordValidationErrMustContainLowerCase"
+  , lengthBetween 5 50 "PasswordValidationErrLength"
+  ]
 
 type VerificationCode = Text
 type UserId = Int

stack.yaml

@@ -40,8 +40,10 @@ packages:
 # - git: https://github.com/commercialhaskell/stack.git
 #   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
 #
-extra-deps: 
+extra-deps:
 - digestive-functors-0.8.4.2
+- git: https://github.com/mmartin/digestive-functors-scotty.git
+  commit: aca9dd5c3df6c64c24b80357051e3ba7ca974b60
 
 # Override default flag values for local packages and extra-deps
 # flags: {}

stack.yaml.lock

@@ -11,6 +11,17 @@ packages:
       sha256: 53ce82c7f0c60c10009b1b764b537117a4ab402bbe1a147fba5ad2263acb3025
   original:
     hackage: digestive-functors-0.8.4.2
+- completed:
+    name: digestive-functors-scotty
+    version: 0.2.0.2
+    git: https://github.com/mmartin/digestive-functors-scotty.git
+    pantry-tree:
+      size: 287
+      sha256: 77635a1be4e267c576791ed305d89f44d7077826383dc8f66b04c50ac5c3da81
+    commit: aca9dd5c3df6c64c24b80357051e3ba7ca974b60
+  original:
+    git: https://github.com/mmartin/digestive-functors-scotty.git
+    commit: aca9dd5c3df6c64c24b80357051e3ba7ca974b60
 snapshots:
 - completed:
     size: 618951

uaa-hs.cabal

@@ -63,6 +63,7 @@ library
     , cookie
     , data-has
     , digestive-functors
+    , digestive-functors-scotty
     , exceptions
     , hedis
     , http-types
@@ -112,6 +113,7 @@ executable uaa-hs-exe
     , cookie
     , data-has
     , digestive-functors
+    , digestive-functors-scotty
     , exceptions
     , hedis
     , http-types
@@ -163,6 +165,7 @@ test-suite uaa-hs-test
     , cookie
     , data-has
     , digestive-functors
+    , digestive-functors-scotty
     , exceptions
     , hedis
     , http-types