UI: WIP: Added Endpoint,Resource and State for Home Page

haskread-platform-ui/spago.yaml

@@ -1,11 +1,18 @@
 package:
   name: haskread-platform-ui
   dependencies:
+    - affjax-web
+    - codec-argonaut
     - console
     - effect
     - halogen
     - halogen-store
+    - http-methods
     - prelude
+    - remotedata
+    - routing
+    - routing-duplex
+    - slug
     - undefined
   test:
     main: Test.Main

haskread-platform-ui/src/Api/Endpoint.purs

@@ -0,0 +1,21 @@
+module Api.Endpoint where
+
+import Prelude hiding ((/))
+
+import Data.Generic.Rep (class Generic)
+import Routing.Duplex (RouteDuplex', prefix, root)
+import Routing.Duplex.Generic (noArgs,sum)
+import Routing.Duplex.Generic.Syntax ((/))
+
+
+data Endpoint
+    = Login
+      | Threads
+
+derive instance genericEndpoint :: Generic Endpoint _
+
+endpointCodec :: RouteDuplex' Endpoint
+endpointCodec = root $ prefix "api" $ sum
+    { "Login" : "users" / "auth" / "login" / noArgs
+    , "Threads" : "threads" / noArgs
+    }

haskread-platform-ui/src/Api/Request.purs

@@ -1,11 +1,56 @@
 module Api.Request where
 
+import Data.HTTP.Method
 import Prelude
 
+import Affjax.RequestHeader (RequestHeader(..))
+import Affjax.Web (Request)
+import Api.Endpoint (Endpoint, endpointCodec)
+import Data.Argonaut.Core (Json)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+import Halogen.HTML.Properties (method)
+import Routing.Duplex (print)
+import Affjax.RequestBody as RB
+import Affjax.ResponseFormat as RF
+
 newtype Token = Token String
 
 derive instance eqToken :: Eq Token
 instance showToken :: Show Token where
-    show (Token _) = "Token {- token -}"
+  show (Token _) = "Token {- token -}"
+
+newtype BaseURL = BaseURL String
+
+type RequestOptions =
+  { endpoint :: Endpoint
+  , method :: RequestMethod
+  }
+
+data RequestMethod
+  = Get
+  | Post (Maybe Json)
+  | Put (Maybe Json)
+  | Delete
 
-newtype BaseURL = BaseURL String
+defaultRequest :: BaseURL -> Maybe Token -> RequestOptions -> Request Json
+defaultRequest (BaseURL baseUrl) auth { endpoint, method } =
+  { method: Left requestMethod
+  , url: baseUrl <> print endpointCodec endpoint
+  , headers: case auth of
+      Nothing -> []
+      Just (Token t) -> [ RequestHeader "Authorization" $ "Token " <> t ]
+  , content: RB.json <$> body
+  , username: Nothing
+  , password: Nothing
+  , timeout: Nothing
+  , withCredentials: false
+  , responseFormat: RF.json
+  }
+  where
+  Tuple requestMethod body = case method of
+    Get -> Tuple GET Nothing
+    Post b -> Tuple POST b
+    Put b -> Tuple PUT b
+    Delete -> Tuple DELETE Nothing

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

@@ -0,0 +1,45 @@
+module Api.Utils where
+
+import Prelude
+
+import Affjax.Web (request)
+import Api.Request (RequestOptions, defaultRequest)
+import Data.Argonaut.Core (Json)
+import Data.Bifunctor (rmap)
+import Data.Codec.Argonaut (JsonCodec)
+import Data.Codec.Argonaut as CA
+import Data.Either (Either(..), hush)
+import Data.Maybe (Maybe(..))
+import Data.Profile (UserName)
+import Effect.Aff.Class (class MonadAff, liftAff)
+import Effect.Class (class MonadEffect)
+import Halogen.Store.Monad (class MonadStore, getStore)
+import Store (Action, Store)
+
+mkRequest :: 
+    forall m. MonadAff m => 
+    MonadStore Action Store m => 
+    RequestOptions -> 
+    m (Maybe Json)
+mkRequest opts = do
+   {baseUrl} <- getStore
+   response <- liftAff $ request $ defaultRequest baseUrl Nothing opts
+   pure $ hush $ rmap _.body response
+
+-- TODO: Add logs upon receving errors
+decode :: forall a. JsonCodec a -> Maybe Json -> Maybe a
+decode _ Nothing = Nothing
+decode codec (Just json) = case CA.decode codec json of
+    Left _ -> Nothing
+    Right response -> (Just response)
+
+decodeWithUser 
+    :: forall m a.
+      MonadEffect m
+   => MonadStore Action Store m
+   => (Maybe UserName -> JsonCodec a)
+   -> Maybe Json
+   -> m (Maybe a)
+decodeWithUser codec json = do
+    {currentUser} <- getStore
+    pure $ decode (codec (_.userName <$> currentUser)) json

haskread-platform-ui/src/AppM.purs

@@ -1,15 +1,34 @@
-module AppM where
+module AppM
+  ( AppM(..)
+  , runAppM
+  )
+  where
 
+import Api.Endpoint
+import Api.Request
+import Api.Utils
 import Prelude
 
+import Api.Endpoint as E
+import Api.Request (RequestOptions, defaultRequest)
+import Api.Utils (decode, mkRequest)
+import Capability.Navigate (class Navigate)
+import Capability.Resource.Thread (class ManageThread)
+import Data.Argonaut.Core (Json)
+import Data.Maybe (Maybe)
+import Data.Route as Route
+import Data.Thread as TH
 import Effect.Aff (Aff)
 import Effect.Aff.Class (class MonadAff)
-import Effect.Class (class MonadEffect)
+import Effect.Class (class MonadEffect, liftEffect)
 import Halogen as H
 import Halogen.Store.Monad (class MonadStore, StoreT, runStoreT)
+import Routing.Duplex (print)
+import Routing.Hash (setHash)
 import Safe.Coerce (coerce)
-import Store (Action,Store)
+import Store (Action, Store)
 import Store as Store
+import Undefined (undefined)
 
 newtype AppM a = AppM (StoreT Store.Action Store.Store Aff a)
 
@@ -26,4 +45,16 @@ derive newtype instance bindAppM :: Bind AppM
 derive newtype instance monadAppM :: Monad AppM
 derive newtype instance monadEffectAppM :: MonadEffect AppM
 derive newtype instance monadAffAppM :: MonadAff AppM
-derive newtype instance monadStoreAppM :: MonadStore Action Store AppM
+derive newtype instance monadStoreAppM :: MonadStore Action Store AppM
+
+instance navigateAppM :: Navigate AppM where
+  navigate =
+    liftEffect <<< setHash <<< print Route.routeCodec
+
+  --TODO: implementing logout logic
+  logout = undefined
+
+instance manageThreadsAppM :: ManageThread AppM where
+    getThreads =
+        mkRequest { endpoint: E.Threads, method: Get }
+            >>= (\mbJson -> pure $ decode TH.threadsCodec mbJson)

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

@@ -0,0 +1,15 @@
+module Capability.Navigate where
+
+import Prelude
+
+import Data.Route (Route)
+import Control.Monad.Trans.Class (lift)
+import Halogen (HalogenM)
+
+class Monad m <= Navigate m where
+  navigate :: Route -> m Unit
+  logout :: m Unit
+
+instance navigateHalogenM :: Navigate m => Navigate (HalogenM st act slots msg m) where
+  navigate = lift <<< navigate
+  logout = lift logout

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

@@ -0,0 +1,13 @@
+module Capability.Resource.Thread where
+
+import Prelude
+
+import Data.Maybe (Maybe)
+import Data.Thread (Thread, PaginatedArray)
+import Halogen (HalogenM, lift)
+
+class Monad m <= ManageThread m where
+    getThreads :: m (Maybe (PaginatedArray Thread))
+
+instance manageThreadHalogenM :: ManageThread m => ManageThread (HalogenM st act slots msg m) where
+    getThreads = lift getThreads

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

@@ -1,7 +1,95 @@
 module Component.Router
-  ( component)
   where
 
+import Data.Route
+import Prelude
+
+import Capability.Navigate (class Navigate, navigate)
+import Capability.Resource.Thread (class ManageThread)
+import Data.Array (elem)
+import Data.Either (hush)
+import Data.Maybe (Maybe(..), fromMaybe, isJust)
+import Data.Profile (Profile)
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class.Console (log)
+import Halogen (liftEffect)
+import Halogen as H
+import Halogen.HTML as HH
+import Halogen.Store.Connect (Connected, connect)
+import Halogen.Store.Monad (class MonadStore)
+import Halogen.Store.Select (selectEq)
+import Page.Home as Home
+import Routing.Duplex as RD
+import Routing.Hash (getHash)
+import Store as Store
+import Type.Proxy (Proxy(..))
 import Undefined (undefined)
 
-component = undefined
+
+data Query a = Navigate Route a
+
+type State = {
+   route :: Maybe Route,
+   currentUser :: Maybe Profile
+ }
+
+data Action = Initialize | Receive (Connected (Maybe Profile) Unit)
+
+type OpaqueSlot slot = forall query. H.Slot query Void slot
+
+type ChildSlots =
+  ( home :: OpaqueSlot Unit
+  , login :: OpaqueSlot Unit
+  , signup :: OpaqueSlot Unit
+  )
+
+component :: 
+  forall m. 
+  MonadAff m => 
+  MonadStore Store.Action Store.Store m => 
+  ManageThread m => 
+  Navigate m => 
+  H.Component Query Unit Void m
+component = connect (selectEq _.currentUser) $ H.mkComponent
+  { initialState: \{context : currentUser} -> { route : Nothing ,currentUser } 
+    , render
+    , eval: H.mkEval H.defaultEval {
+      handleQuery = handleQuery,
+      handleAction = handleAction,
+      receive = Just <<< Receive,
+      initialize = Just Initialize
+    }
+  }
+  where
+    handleAction :: Action -> H.HalogenM State Action ChildSlots Void m Unit
+    handleAction = case _ of
+      Initialize -> do
+        log "Here!"
+        initialRoute <- hush <<< (RD.parse routeCodec) <$> liftEffect getHash
+        log $ "here as well" <> show initialRoute
+        navigate $ fromMaybe Home initialRoute
+      Receive { context : currentUser } -> 
+        H.modify_ _ { currentUser = currentUser }
+
+    handleQuery :: forall a. Query a -> H.HalogenM State Action ChildSlots Void m (Maybe a)
+    handleQuery = case _ of
+      Navigate dest a -> do
+       log "reacheddd"
+       { route , currentUser } <- H.get
+       H.modify_ _ { route = Just dest }
+       pure (Just a)
+      _ -> log "not reachging Navigate" *> pure Nothing
+
+    -- authorize :: Maybe Profile -> H.ComponentHTML Action ChildSlots m -> H.ComponentHTML Action ChildSlots m
+    -- authorize mbProfile html = case mbProfile of
+    --   Nothing ->
+    --     undefined --HH.slot (Proxy :: _ "login") unit Login.component { redirect: false } absurd
+    --   Just _ ->
+    --     html
+
+    render :: State -> H.ComponentHTML Action ChildSlots m
+    render {route,currentUser} = case route of
+      Just r -> case r of
+        Home -> HH.slot_ (Proxy :: _ "home") unit Home.component unit
+        _ -> HH.div_ [ HH.text "Oh no! That " ]
+      Nothing ->  HH.div_ [ HH.text "Oh no!! That page wasn't found." ]

haskread-platform-ui/src/Data/Profile.purs

@@ -1,11 +1,23 @@
-module Data.Profile (Profile,ProfileRep,UserName,Avatar,UserID) where
+module Data.Profile
+  ( Avatar
+  , Profile
+  , UserID
+  , UserName
+  , ProfileRep
+  )
+  where
 
+import Prelude
 
 newtype UserID = UserID Int
 newtype UserName = UserName String
 newtype Avatar = Avatar String
 newtype Email = Email String
 
+derive newtype instance eqUserName :: Eq UserName
+derive newtype instance eqUserID :: Eq UserID
+derive newtype instance eqAvatar :: Eq Avatar
+
 type ProfileRep row = (
     userID :: UserID
    , userName :: UserName

haskread-platform-ui/src/Data/Route.purs

@@ -0,0 +1,34 @@
+module Data.Route where
+
+import Prelude hiding ((/))
+
+import Data.Generic.Rep (class Generic)
+import Routing.Duplex (RouteDuplex', as, root)
+import Routing.Duplex.Generic (noArgs, sum)
+import Routing.Duplex.Generic.Syntax ((/))
+import Slug (Slug)
+import Slug as Slug
+import Data.Either (note)
+
+data Route = Home 
+            | Login
+            | Signup 
+
+derive instance genericRoute :: Generic Route _
+derive instance eqRoute :: Eq Route
+derive instance ordRoute :: Ord Route
+
+instance showRoute :: Show Route where
+    show Home = "Home" 
+    show Login = "Home" 
+    show Signup = "Home" 
+
+routeCodec :: RouteDuplex' Route
+routeCodec = root $ sum {
+    "Home" :  noArgs,
+    "Login" : "login" / noArgs,
+    "Signup" : "signup" / noArgs   
+ }
+
+slug :: RouteDuplex' String -> RouteDuplex' Slug
+slug = as Slug.toString (Slug.parse >>> note "Bad slug")