UI: Added registration page

haskread-platform-ui/Makefile

@@ -0,0 +1,2 @@
+run-haskread-platform-ui:
+	spago bundle && python3 -m http.server

haskread-platform-ui/README.md

@@ -8,4 +8,10 @@ The UI of Haskread application.
 - Halogen
 - Bulma CSS
 
-### The architechture of this application is highly inspired by `[Real-World-Halogen]()`
+### The architechture of this application is highly inspired by `[Real-World-Halogen]()`
+
+### TODO:
+
+- Add Registration Page
+- After registration is successful, the page should be redirected to OTP page. From OTP upon success,
+  the page should be redirected to login page.

haskread-platform-ui/src/AppM.purs

@@ -10,7 +10,7 @@ import Capability.Navigate (class Navigate)
 import Capability.Resource (class ManageThreads,class ManageUser)
 import Common.Types (Endpoint(..), RequestMethod(..), threadsCodec)
 import Common.Types as Route
-import Common.Utils (mkRequest, decode, authenticate,login)
+import Common.Utils (mkRequest, decode, authenticate,login,register)
 import Effect.Aff (Aff)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Class (class MonadEffect, liftEffect)
@@ -48,4 +48,5 @@ instance threadHalogenM :: ManageThreads AppM where
        decode threadsCodec mjson
 
 instance manageUserAppM :: ManageUser AppM where
-  loginUser = authenticate login
+  loginUser = authenticate login
+  registerUser = register

haskread-platform-ui/src/Capability/Resource.purs

@@ -1,8 +1,9 @@
 module Capability.Resource where
 
 import Halogen (HalogenM, lift)
-import Common.Types (PaginatedArray,Thread,LoginFields,Profile)
+import Common.Types (PaginatedArray,Thread,LoginFields,Profile,RegisterFields)
 import Data.Maybe (Maybe)
+import Data.Either (Either)
 
 import Prelude
 
@@ -14,8 +15,9 @@ instance manageThreadHalogenM :: ManageThreads m => ManageThreads (HalogenM st a
 
 class Monad m <= ManageUser m where
   loginUser :: LoginFields -> m (Maybe Profile)
-
+  registerUser :: RegisterFields -> m (Either String Unit)
 
 -- | This instance lets us avoid having to use `lift` when we use these functions in a component.
 instance manageUserHalogenM :: ManageUser m => ManageUser (HalogenM st act slots msg m) where
   loginUser = lift <<< loginUser
+  registerUser = lift <<< registerUser

haskread-platform-ui/src/Common/Types.purs

@@ -14,35 +14,39 @@ module Common.Types
   , profileCodec 
   , Profile
   , LoginFields
+  , RegisterFields
   , loginCodec
+  , registerCodec
   )
   where
 
 import Prelude hiding ((/))
+
+import Data.Argonaut.Core (Json)
+import Data.Codec ((>~>))
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Compat as CAC
+import Data.Codec.Argonaut.Migration as CAM
+import Data.Codec.Argonaut.Record as CAR
 import Data.Generic.Rep (class Generic)
-import Routing.Duplex.Generic as G
 import Data.Maybe (Maybe)
 import Routing.Duplex (RouteDuplex', int, path, optional, prefix, root, segment, string)
 import Routing.Duplex.Generic (noArgs, sum)
+import Routing.Duplex.Generic as G
 import Routing.Duplex.Generic.Syntax ((/), (?))
-import Data.Argonaut.Core (Json)
-import Data.Codec.Argonaut (JsonCodec)
-import Data.Codec.Argonaut.Record as CAR
-import Data.Codec ((>~>))
-import Data.Codec.Argonaut.Migration as CAM
-import Data.Codec.Argonaut as CA
-import Data.Codec.Argonaut.Compat as CAC
 
 newtype BaseURL = BaseURL String
 
-data Endpoint = Threads | UserByToken | Login0
+data Endpoint = Threads | UserByToken | Login0 | Register0
 derive instance genericEndpoint :: Generic Endpoint _
 
 endpointCodec :: RouteDuplex' Endpoint
 endpointCodec = root $ sum { 
     "Threads" : "api" / "v1" / "thread" / "all" / noArgs ,
     "UserByToken" : "api" / "v1" / "user" / "profile" / noArgs,
-    "Login0" : "api" / "v1" / "user" / "auth" / "login" / noArgs
+    "Login0" : "api" / "v1" / "user" / "auth" / "login" / noArgs,
+    "Register0" : "api" / "v1" / "user" / "auth" / "register" / noArgs
     }
 
 data RequestMethod = 
@@ -56,6 +60,7 @@ type RequestOptions =
 data MyRoute =
       Home
     | Login
+    | Register
 
 derive instance genericRoute :: Generic MyRoute _
 derive instance eqRoute :: Eq MyRoute
@@ -70,6 +75,7 @@ myRoute :: RouteDuplex' MyRoute
 myRoute = root $ G.sum {
         "Home" : G.noArgs
       , "Login" : path "login" G.noArgs
+      , "Register" : path "register" G.noArgs
     }
 
 type PaginatedArray a =
@@ -124,12 +130,25 @@ type LoginFields =
   , passwordForLogin :: String
   }
 
+type RegisterFields = {
+    userNameForRegister :: String
+   , emailForRegister :: String
+   , passwordForRegister :: String
+   , confirmPasswordForRegister :: String
+}
+
 loginCodec :: JsonCodec LoginFields
 loginCodec =
   CAR.object "LoginFields"
     { emailForLogin: CA.string
     , passwordForLogin: CA.string
     }
 
-
-
+registerCodec :: JsonCodec RegisterFields
+registerCodec =
+  CAR.object "LoginFields"
+    { userNameForRegister: CA.string
+    , emailForRegister : CA.string
+   , passwordForRegister : CA.string
+   , confirmPasswordForRegister : CA.string
+    }

haskread-platform-ui/src/Common/Utils.purs

@@ -2,15 +2,15 @@ module Common.Utils where
 
 import Prelude
 
-import Affjax (printError,Error,Response)
+import Affjax (printError)
 import Affjax.RequestBody as RB
 import Affjax.RequestHeader (RequestHeader(..))
 import Affjax.ResponseFormat as RF
 import Affjax.Web (request, Request)
 import Common.Types -- (BaseURL(..), Token(..), RequestOptions, RequestMethod(..), endpointCodec,Profile)
 import Data.Argonaut.Core (Json)
-import Data.Bifunctor (rmap)
-import Data.Codec.Argonaut (JsonCodec)
+import Data.Bifunctor (rmap,lmap)
+import Data.Codec.Argonaut (JsonCodec,JsonDecodeError, printJsonDecodeError)
 import Data.Codec.Argonaut as CA
 import Data.Either (Either(..), hush)
 import Data.HTTP.Method (Method(..))
@@ -21,19 +21,16 @@ import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Class.Console (log)
 import Halogen.Store.Monad (class MonadStore, getStore,updateStore)
 import Routing.Duplex (print)
-import Store (Action, Store, Action(..))
+import Store (Store, Action(..))
 import Web.HTML.Window (localStorage)
 import Web.Storage.Storage (getItem, removeItem, setItem)
 import Effect (Effect)
 import Effect.Aff (Aff)
 import Web.HTML (window)
 import Data.Codec as Codec
 import Data.Codec.Argonaut.Record as CAR
-import Data.Codec.Argonaut (JsonCodec, JsonDecodeError, printJsonDecodeError)
-import Data.Bifunctor (lmap)
-import Halogen (lift)
-
-import Undefined (undefined)
+import Halogen.HTML as HH
+import Halogen.HTML.Properties as HP
 
 mkRequest
   :: forall m
@@ -84,6 +81,12 @@ defaultRequest (BaseURL baseUrl) auth { endpoint, method } =
 
 tokenKey = "token" :: String
 
+safeHref :: forall r i. MyRoute -> HH.IProp (href :: String | r) i
+safeHref = HP.href <<< append "#" <<< print myRoute
+
+whenElem :: forall p i. Boolean -> (Unit -> HH.HTML p i) -> HH.HTML p i
+whenElem cond f = if cond then f unit else HH.text ""
+
 readToken :: Effect (Maybe Token)
 readToken = do
   str <- getItem tokenKey =<< localStorage =<< window
@@ -125,18 +128,26 @@ login baseUrl fields =
   in
     requestUser baseUrl { endpoint: Login0, method }
 
+register :: forall m. 
+    MonadStore Action Store m => 
+    MonadAff m => RegisterFields -> m (Either String Unit)
+register fields = do
+    let method = Post $ Just $ Codec.encode registerCodec fields
+    mjson <- mkRequest { endpoint: Register0, method }
+    case mjson of
+        Nothing -> pure $ Left "got nothing"
+        Just _ -> pure $ Right unit
+
 requestUser :: forall m. MonadAff m => BaseURL -> RequestOptions -> m (Either String (Tuple Token Profile))
 requestUser baseUrl opts = do
   eRes <- liftAff $ request $ defaultRequest baseUrl Nothing opts
-  log "reached here!"
   case eRes of
     Left e -> pure $ Left $ printError e
     Right v -> do 
-      log "reached here@!"
       let eToken = lmap printJsonDecodeError $ decodeToken v.body
       case eToken of
         Left err -> do
-          log $ "got error" <> err 
+          log $ "got error: " <> err 
           pure $ Left err
         Right token -> do
           _ <- liftEffect $ writeToken token
@@ -171,4 +182,4 @@ getCurrentUser baseUrl = do
                     Left "error fetching request"
                 Right v -> lmap printJsonDecodeError do
                     CA.decode profileCodec v.body
-           pure $ hush user
+           pure $ hush user

haskread-platform-ui/src/Component/Common.purs

@@ -0,0 +1,3 @@
+module Component.Common where
+
+import Prelude

haskread-platform-ui/src/Component/Router.purs

@@ -6,22 +6,20 @@ import Prelude
 import Halogen as H
 import Halogen.HTML as HH
 import Undefined
-
 import Common.Types (myRoute,MyRoute(..),Profile)
 import Data.Maybe (Maybe(..))
 import Routing.Duplex as RD
 import Data.Either (Either(..))
-
 import Effect.Class.Console (log)
 import Effect.Class (class MonadEffect,liftEffect)
 import Capability.Navigate (class Navigate,navigate)
 import Capability.Resource (class ManageThreads,class ManageUser)
 import Effect.Aff.Class (class MonadAff)
-
 import Routing.Hash (getHash)
 import Type.Proxy (Proxy(..))
 import Page.Home as Home
 import Page.Login as Login
+import Page.Register as Register
 import Common.Utils (readToken)
 import Halogen.Store.Connect (Connected, connect)
 import Halogen.Store.Select (selectEq)
@@ -42,6 +40,7 @@ type OpaqueSlot slot = forall query. H.Slot query Void slot
 type ChildSlots =
   ( home :: OpaqueSlot Unit
   , login :: OpaqueSlot Unit
+  , register :: OpaqueSlot Unit
   )
 
 component :: forall m.
@@ -69,7 +68,7 @@ component = connect (selectEq _.currentUser) $ H.mkComponent {
             Initialize -> do
                 url <- liftEffect getHash
                 case RD.parse myRoute url of
-                    Left e -> log $ "err" <> show e
+                    Left e -> (log $ "err" <> show e) *> navigate Home
                     Right r -> navigate r
             Receive { context: currentUser } -> do
                 log $ "user" <> show currentUser
@@ -84,6 +83,7 @@ component = connect (selectEq _.currentUser) $ H.mkComponent {
     render :: State -> H.ComponentHTML Action ChildSlots m 
     render {route} = case route of  
                 Just r -> case r of
-                              Home -> HH.slot_ (Proxy :: _ "home") unit Home.component unit
-                              Login -> HH.slot_ (Proxy :: _ "login") unit Login.component { redirect: true }
+                    Home -> HH.slot_ (Proxy :: _ "home") unit Home.component unit
+                    Login -> HH.slot_ (Proxy :: _ "login") unit Login.component { redirect: true }
+                    Register -> HH.slot_ (Proxy :: _ "register") unit Register.component { redirect: true }
                 Nothing -> HH.div_ [ HH.text "page not found!" ]

haskread-platform-ui/src/Form/Validation.purs

@@ -2,27 +2,23 @@ module Form.Validation where
 
 import Prelude
 
-
-import Data.Either (Either(..), note)
-import Data.Maybe (Maybe(..))
+import Data.Either (Either(..))
 import Data.String as String
 
 data FormError
   = Required
   | TooShort
   | TooLong
   | InvalidEmail
-  | InvalidUsername
-  | InvalidAvatar
+  | PasswordsDidNotMatched
 
 errorToString :: FormError -> String
 errorToString = case _ of
   Required -> "This field is required."
   TooShort -> "Not enough characters entered"
   TooLong -> "Too many characters entered"
   InvalidEmail -> "Invalid email address"
-  InvalidUsername -> "Invalid username"
-  InvalidAvatar -> "Invalid image URL"
+  PasswordsDidNotMatched -> "Passwords did not match"
 
 required :: forall a. Eq a => Monoid a => a -> Either FormError a
 required = check (_ /= mempty) Required
@@ -36,25 +32,10 @@ maxLength n = check (\str -> String.length str <= n) TooLong
 emailFormat :: String -> Either FormError String
 emailFormat = check (String.contains (String.Pattern "@")) InvalidEmail
 
--- usernameFormat :: String -> Either FormError Username
--- usernameFormat = note InvalidUsername <<< Username.parse
-
--- avatarFormat :: String -> Either FormError Avatar
--- avatarFormat = note InvalidAvatar <<< Avatar.parse
+passwordsEqual :: String -> String -> Either FormError String
+passwordsEqual p1 = check (\x -> x==p1) PasswordsDidNotMatched
 
 check :: forall a. (a -> Boolean) -> FormError -> a -> Either FormError a
 check f err a
   | f a = Right a
-  | otherwise = Left err
-
--- toOptional
---   :: forall a b
---    . Monoid a
---   => Eq a
---   => (a -> Either FormError b)
---   -> (a -> Either FormError (Maybe b))
--- toOptional k = \value ->
---   if value == mempty then
---     Right Nothing
---   else
---     map Just $ k value
+  | otherwise = Left err