signup

router.purs

module Router where

--http://www.parsonsmatt.org/2015/10/22/purescript_router.html
--https://github.com/parsonsmatt/purescript-routing-example/blob/master/src/Router.purs
--https://github.com/slamdata/slamdata/blob/13a6e619248386a5fd868326a1cf517c0ef124c4/src/SlamData/Prelude.purs#L116
--https://github.com/slamdata/slamdata/blob/13a6e619248386a5fd868326a1cf517c0ef124c4/src/SlamData/Workspace/Component/ChildSlot.purs


import BigPrelude
import Routing (matchesAff)
import Routing.Match (Match)
import Routing.Match.Class (lit, num)
import Component.SignUp as SignUp
import Component.Profile as Profile
import Component.Sessions as Sessions
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Control.Monad.Aff (Aff)
import Control.Monad.State.Class (modify)
import Data.Functor.Coproduct (Coproduct)
import Data.String (toLower)
import Halogen.Component.ChildPath as CP
import Data.Const (Const)
import Control.Monad.Eff.Console (log, CONSOLE)
import Network.HTTP.Affjax (AJAX)

infixr 4 type Either as ⊹
infixr 4 type Coproduct as ⨁

data Input a
  = Goto Routes a

data CRUD
  = Index
  | Show Number

data Routes
  = Profile
  | Sessions CRUD
  | Home
  | SignUp

init :: State
init = { currentPage: "Home" }

routing :: Match Routes
routing = profile
      <|> signup
      <|> sessions
      <|> home
  where
    profile = Profile <$ route "profile"
    signup = SignUp <$ route "signup"
    home = Home <$ lit ""
    sessions = Sessions <$> (route "sessions" *> parseCRUD)
    route str = lit "" *> lit str
    parseCRUD = Show <$> num <|> pure Index

type State =
  { currentPage :: String
  }

type ChildQuery = Profile.Input ⨁ Sessions.Input ⨁ SignUp.Input ⨁ Const Void
type ChildSlot = Profile.Slot ⊹ Sessions.Slot ⊹ SignUp.Slot ⊹ Void

pathToProfile :: CP.ChildPath Profile.Input ChildQuery Profile.Slot ChildSlot
pathToProfile = CP.cp1

pathToSessions :: CP.ChildPath Sessions.Input ChildQuery Sessions.Slot ChildSlot
pathToSessions = CP.cp2

pathToSignUp :: CP.ChildPath SignUp.Input ChildQuery SignUp.Slot ChildSlot
pathToSignUp = CP.cp3

ui :: ∀ m. H.Component HH.HTML Input Unit Void (Aff (console :: CONSOLE, ajax :: AJAX | m))
ui = H.parentComponent
  { initialState: const init
  , render
  , eval
  , receiver: const Nothing
  }
  where
    render :: State -> H.ParentHTML Input ChildQuery ChildSlot (Aff (console :: CONSOLE, ajax :: AJAX | m))
    render st =
      viewPage st.currentPage
--      HH.div_
--        [ HH.h1_ [ HH.text (st.currentPage) ]
--        , HH.ul_ (map link ["Sessions", "Profile", "Home", "SignUp"])
--        , viewPage st.currentPage
--        ]

--    link s = HH.li_ [ HH.a [ HP.href ("#/" <> toLower s) ] [ HH.text s ] ]

    viewPage :: String -> H.ParentHTML Input ChildQuery ChildSlot (Aff (console :: CONSOLE, ajax :: AJAX | m))
    viewPage "Sessions" =
      HH.slot' pathToSessions Sessions.Slot Sessions.ui unit absurd
    viewPage "Profile" =
      HH.slot' pathToProfile Profile.Slot Profile.ui unit absurd
    viewPage "SignUp" =
      HH.slot' pathToSignUp SignUp.Slot SignUp.ui unit absurd
    viewPage _ =
      HH.div_ []

    eval :: Input ~> H.ParentDSL State Input ChildQuery ChildSlot Void (Aff (console :: CONSOLE, ajax :: AJAX | m))
    eval (Goto Profile next) = do
      modify (_ { currentPage = "Profile" })
      pure next
    eval (Goto SignUp next) = do
      modify (_ { currentPage = "SignUp" })
      pure next
    eval (Goto (Sessions view) next) = do
      modify case view of
                  Index -> (_ { currentPage = "Sessions" })
                  Show n -> (_ { currentPage = "Session " <> show n })
      pure next
    eval (Goto Home next) = do
      modify (_ { currentPage = "Home" })
      pure next

routeSignal :: ∀ eff. H.HalogenIO Input Void (Aff (HA.HalogenEffects eff))
            -> Aff (HA.HalogenEffects eff) Unit
routeSignal driver = do
  Tuple old new <- matchesAff routing
  redirects driver old new


-- redirects driver _ Home =
--   driver (left (action (Goto Home))))
-- redirects driver _ Profile =
--   driver (left (action (Goto Profile))))
-- redirects driver _ (Sessions view) =
--   driver (left (action (Goto (Sessions view)))))
redirects :: ∀ eff. H.HalogenIO Input Void (Aff (HA.HalogenEffects eff))
          -> Maybe Routes
          -> Routes
          -> Aff (HA.HalogenEffects eff) Unit
redirects driver _ =
  driver.query <<< H.action <<< Goto

signup.purs

module Component.SignUp where

import Data.Maybe (Maybe(..))
import Halogen as H
import Halogen.HTML
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties
import Halogen.HTML.Properties.ARIA hiding (label)
import Prelude hiding (div)
import Data.Argonaut (Json, encodeJson, jsonFalse, jsonTrue, jsonEmptyObject, class DecodeJson, class EncodeJson, decodeJson, (.?), (:=), (~>))
import Data.Argonaut.Parser (jsonParser)
import Data.Either (Either(..))
import Data.Traversable (traverse)
import Network.HTTP.Affjax (AJAX, get, put, post)
import Debug.Trace (traceAnyA, spy, traceA, traceAnyM, traceAny, traceShow, trace)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Control.Monad.Aff (Aff)

data Input a
  = Noop a
    | SetUserNameInput String a
    | SetUserEmailInput String a
    | SetUserPasswordInput String a
    | SetUserConfirmPasswordInput String a
    | DoRegister a


data Message = Message {
   message :: String
   , status :: String
 }

instance messageDecoder :: DecodeJson Message where
  decodeJson json = do
   obj     <- decodeJson json
   message <- obj .? "message"
   status  <- obj .? "status"
   pure $ Message { message, status }



instance signUpEncoder :: EncodeJson SignUpRequest where
  encodeJson (SignUpRequest signup)
     = "email" := signup.email
    ~> "password" := signup.password
    ~> jsonEmptyObject


decodeMessage :: forall e. String -> Either String Message
decodeMessage stringJson = do
 json <- jsonParser stringJson
 decodeJson json


data SignUpRequest = SignUpRequest {
  email :: String
  , password :: String
 }

type Model = {
   username :: String
   , email :: String
   , password :: String
   , confirmPassword :: String
   , message :: Maybe Message
 }

-- slot stuff as this is a child that slots into the parent in the router view
data Slot = Slot
derive instance eqSlot :: Eq Slot
derive instance ordSlot :: Ord Slot

class' :: forall r i. String -> IProp ("class" :: String | r) i
class' name = class_ (ClassName name)

attr' :: forall r i. String -> String -> IProp r i
attr' name = attr (AttrName name)

initialState :: Unit -> Model
initialState = const $ {
     username : ""
   , email : ""
   , password : ""
   , confirmPassword : ""
   , message : Nothing
 }

ui :: forall m. H.Component HTML Input Unit Void (Aff (console :: CONSOLE, ajax :: AJAX | m))
ui = H.component
  { initialState: initialState
  , render
  , eval
  , receiver: const Nothing
  }
  where
    render _ =
      section [ class' "auth-layout" ] [
        h1 [ class' "at-form-landing-logo"] [
          img [ alt "Wekan", src "/assets/images/wekan-logo.png"]
        ]
        , div [ class' "at-form"] [
          div [ class' "at-title"] [
            h3 [] [ text "Create an Account"]
          ]
        , registerForm
        , div [ class' "at-signin-link"] [
            p [] [ text "If you already have an account ",
            a [ class' "at-link-at-signin", href "#login", id_ "at-signIn"] [ text "sign in"]
            ]
          ]
        ]
      ]

    eval :: Input ~> H.ComponentDSL Model Input Void (Aff (console :: CONSOLE, ajax :: AJAX | m))
    eval = case _ of
      Noop next -> do
        pure next

      SetUserNameInput username next -> do
        pure next

      SetUserEmailInput email next -> do
        H.liftEff (log ("in set email: " <> email))
        H.modify (_ { email = email })
        pure next

      SetUserPasswordInput password next -> do
        H.modify (_ { password = password })
        pure next

      SetUserConfirmPasswordInput confirmPassword next -> do
        H.modify (_ { confirmPassword = confirmPassword })
        pure next

      DoRegister next -> do
--        traceA "Hello"
        model <- H.get
        _ <- H.liftAff $ (attemptRegister model.email model.password)
--        H.liftEff (log model.email )

        pure next


attemptRegister email password = do
  res <- post "signup" $ encodeJson $ SignUpRequest {email, password}
  pure $ decodeMessage res.response



registerForm :: forall a. HTML a (Input Unit)
registerForm =
  div [ class' "at-pwd-form"] [
    div [ id_ "at-pwd-form", role "form" ] [
      div [ class' "at-input"] [
        label [ for "at-field-username"] [ text "Username"]
        , input [  HE.onValueInput (HE.input (SetUserNameInput)), attr' "autocapitalize" "none", attr' "autocorrect" "off", id_ "at-field-username", name "at-field-username", placeholder "Username", type_ InputText ]
      ]
      , div [ class' "at-input"] [
          label [ for "at-field-email"] [ text "Email"]
          , input [ HE.onValueInput (HE.input (SetUserEmailInput)), attr' "autocapitalize" "none", attr' "autocorrect" "off", id_ "at-field-email", name "at-field-email", placeholder "Email", type_ InputEmail ]
        ]
      , div [ class' "at-input"] [
          label [ for "at-field-password"] [ text "Password"]
          , input [ HE.onValueInput (HE.input (SetUserPasswordInput)), attr' "autocapitalize" "none", attr' "autocorrect" "off", id_ "at-field-password", name "at-field-password", placeholder "Password", type_ InputPassword ]
        ]
      , div [ class' "at-input"] [
          label [ for "at-field-password-confirm"] [ text "Confirm Password"]
          , input [ HE.onValueInput (HE.input (SetUserConfirmPasswordInput)), attr' "autocapitalize" "none", attr' "autocorrect" "off", id_ "at-field-password-confirm", name "at-field-password-confirm", placeholder "Confirm password", type_ InputPassword ]
        ]
      , button [ HE.onClick (HE.input_ (DoRegister)), class' "at-btn submit", id_ "at-btn"] [ text "Register"]
    ]
  ]