Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Initial structure for the second sprint #46

Open
wants to merge 55 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
55 commits
Select commit Hold shift + click to select a range
9ed9a87
Initial structure for the second sprint
meditans Oct 31, 2016
c108244
First translation with reflex-jsx
meditans Oct 31, 2016
1132e07
Add roundup document
meditans Oct 31, 2016
1a2cabb
Add Permission and Role datatypes
meditans Oct 31, 2016
d37eaf2
Initial stub for generic structures
meditans Nov 1, 2016
40d9ca0
API with permissions
meditans Nov 2, 2016
9c83262
Server implementing deleteuser protocol
meditans Nov 2, 2016
0b71e29
Extracting the api declaration (part 1)
meditans Nov 3, 2016
1d67cd4
Solved standalone api client problem
meditans Nov 3, 2016
db92f05
New server and client
meditans Nov 3, 2016
2e76fdd
New persistent api and server
meditans Nov 3, 2016
f508991
Added reflex-dom-contrib
meditans Nov 3, 2016
bd28b9f
Translation of the first page
meditans Nov 3, 2016
0612bcd
Change code organization
meditans Nov 4, 2016
da8fb7e
Add styles.min.css
meditans Nov 4, 2016
3015691
Complete transcript of the second page
meditans Nov 4, 2016
883d689
Preliminary client version
meditans Nov 7, 2016
1a14bb0
Preliminary precompiled js
meditans Nov 7, 2016
b3b106f
Refactored mockAPI
meditans Nov 7, 2016
ef920c4
Refactored mockServer
meditans Nov 7, 2016
99fc950
Update client, and fix minor checkbox bug
meditans Nov 7, 2016
7d56b97
Stub of shaped validation
meditans Nov 10, 2016
5215423
Complete export of Shaped
meditans Nov 11, 2016
c47ebec
Better version of add user widget
meditans Nov 11, 2016
9b497dc
Added complete validation/error interface
meditans Nov 14, 2016
51969e6
Updated js
meditans Nov 14, 2016
dc3137f
Added example to roundup
meditans Nov 14, 2016
c22d09a
Wip (problems with git)
meditans Nov 14, 2016
4c6b198
Fixed errors on blank user
meditans Nov 15, 2016
b5f0080
Completed ui errors on save
meditans Nov 15, 2016
b9d6c1b
Updated js
meditans Nov 15, 2016
d267fa0
Cleaning up
meditans Nov 15, 2016
e15480b
Added common ui library
meditans Nov 15, 2016
2de7a65
Added endpoint for adding user
meditans Nov 15, 2016
47a04c4
Added better abstraction for buttons and apis
meditans Nov 15, 2016
99da46e
Added dependency of external library (without the bug)
meditans Nov 16, 2016
b48c90c
Fixed the looping tvar bug
meditans Nov 16, 2016
fa8aca9
Pre-routing
meditans Nov 16, 2016
f739faa
WIP routing, I have still routing malfunctions
meditans Nov 18, 2016
ac680bb
Use only one raw endpoint
meditans Nov 20, 2016
778a9bb
Routing minus the ffi window.location trick
meditans Nov 21, 2016
1dcdd9b
Delete the big js file and add it to the gitignore (for development)
meditans Nov 29, 2016
2b17139
Remove reference to ghcjs to resume compilation with ghc
meditans Nov 29, 2016
5eb1044
Updated reflex-dom-contrib version, commented old routing main
meditans Nov 29, 2016
dcdad22
[WIP] demonstrate problem
meditans Dec 2, 2016
bd0b506
The script execution should be deferred and happen in the body
meditans Dec 2, 2016
9f1dd74
Updated to last version of the webroutes branch
meditans Dec 2, 2016
e4c9317
BootApp has a text parameter now
meditans Dec 2, 2016
ed86de3
Removed most of dead code
meditans Dec 2, 2016
0fc5aa1
[WIP]
meditans Dec 5, 2016
3826075
Simplification [WIP]
meditans Dec 5, 2016
3cf5074
Refactoring to make the code clearer for the tutorial
meditans Dec 10, 2016
acc31a8
WIP (Old files needed for examples and explanations)
meditans Dec 21, 2016
6be9611
Updated to the new lts to mantain the same compiler
meditans Jan 11, 2017
2e2b25a
Moving manually translated html to quasiquoter
meditans Jan 11, 2017
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions .gitignore
Original file line number Diff line number Diff line change
Expand Up @@ -17,3 +17,4 @@ cabal.sandbox.config
*.eventlog
.stack-work/
cabal.project.local
UI/ReflexFRP/mockUsersRoles/mockClient/js/all.min.js
22 changes: 15 additions & 7 deletions UI/ReflexFRP/mockLoginPage/mockClient/Main.hs
Original file line number Diff line number Diff line change
@@ -1,6 +1,8 @@
{-# LANGUAGE ExplicitForAll, NoImplicitPrelude, NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings, RecursiveDo, ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ExplicitForAll, FlexibleContexts, NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures, RankNTypes, RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications, TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -fdefer-typed-holes #-}

Expand All @@ -18,12 +20,18 @@ import MockAPI
main :: IO ()
main = mainWidget body

url :: BaseUrl
url = BaseFullUrl Http "localhost" 8081 ""

allApi :: forall t m. (MonadWidget t m) => _
allApi = client (Proxy @MockApi) (Proxy :: Proxy m) (constDyn url)

invokeAPI :: forall t m. (MonadWidget t m) =>
Dynamic t (Either Text User) -> Event t () -> m (Event t (ReqResult Text))
(invokeAPI :<|> _ :<|> _) = allApi

body :: forall t m. MonadWidget t m => m ()
body = do
-- Instructions to use the server at localhost and to invoke the api
let url = BaseFullUrl Http "localhost" 8081 ""
(invokeAPI :<|> _ :<|> _) = client (Proxy @MockApi) (Proxy @m) (constDyn url)

-- A description of the visual elements
divClass "login-clean" $ do
el "form" $ do
Expand Down
28 changes: 28 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/README.org
Original file line number Diff line number Diff line change
@@ -0,0 +1,28 @@
* Login with server side validation

This repo implements a ui form for server side user validation.

From a technical stanpoint, the aim of this project is to see how various
libraries fit together: =reflex= and =reflex-dom= for the frontend, a simple
=servant= server on the backend, the bridge among the two worlds being made with
=servant-reflex=.

Note the structure of the project: three separate cabal projects are created,
one for the frontend, one for the backend, and one for the API and the shared
datatypes, which is included in the other two.

Also, in the frontend I provided two stack.yaml files. The main one is intended
to be used with =ghc=, it generates the haddocks, behaves well with the tooling
(intero), and builds a standalone desktop app.

The second one, =stack-ghcjs.yaml= compiles the project with =ghcjs=. To call
the stack commands for ghcjs just add the option =--stack-yaml=stack-ghcjs.yaml=.

The build of the server should be just a =stack build=. To build the client:
- =stack build gtk2hs-buildtools alex happy=
- be sure to have the required system libraries (like webkitgtk)
- =stack build= or =stack build --stack-yaml=stack-ghcjs.yaml=

You can also use the =deploy.hs= in the client folder, which compiles the
client, minimizes the generated js, and copies it in the location expected by
the server.
2 changes: 2 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/Setup.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain
29 changes: 29 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/mockAPI.cabal
Original file line number Diff line number Diff line change
@@ -0,0 +1,29 @@
name: mockAPI
version: 0.1.0.0
build-type: Simple
cabal-version: >=1.10

library
hs-source-dirs: src
exposed-modules: MockAPI
, MockAPI.Prelude
, GenericStructure
, MockAPI.Shaped
, MockAPI.Permission
, MockAPI.User
, MockAPI.RoleAttributes
, MockAPI.Roles
build-depends: base >= 4.7 && < 5
, servant
, text
, aeson
, mtl
, containers
, lens
, digestive-functors
, email-validate
, string-conversions >= 0.4
, servant-router
, servant-blaze
, blaze-html
default-language: Haskell2010
76 changes: 76 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/GenericStructure.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,76 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}

module GenericStructure where

import Data.Aeson
import Data.Text
import GHC.Generics
import Control.Monad.Identity
import Control.Applicative
import Data.Functor.Classes

newtype Mail = Mail {unMail :: Text} deriving (Eq, Show)

data User' f = User'
{ userName :: f Text
, userMail :: f Mail
}

instance (Show1 f) => Show (User' f) where
show (User' ft fm) = Prelude.unwords ["User'", par $ show1 ft, par $ show1 fm]
where par x = "(" ++ x ++ ")"
show1 x = showsPrec1 0 x ""

instance Eq1 f => Eq (User' f) where
(User' ft1 fm1) == (User' ft2 fm2) = eq1 ft1 ft2

type Simple x = x Identity
type Validated x = x Validation
type Diff x = x Difference

newtype Validation a = Validation { unValidation :: Const (a -> Text) a }
newtype Difference a = Difference { unDifference :: Maybe a } deriving (Show1)

-- Let's test some composite structure
data CoupleOfUsers' f = CoupleOfUsers'
{ firstUser :: f (User' f)
, secondUser :: f (User' f)
}

instance (Show1 f) => Show (CoupleOfUsers' f) where
show (CoupleOfUsers' ft fm) = Prelude.unwords ["CoupleOfUsers'", par $ show1 ft, par $ show1 fm]
where par x = "(" ++ x ++ ")"
show1 x = showsPrec1 0 x ""

couple :: Simple User' -> Simple User' -> Simple CoupleOfUsers'
couple u1 u2 = CoupleOfUsers' (Identity u1) (Identity u2)

-- Example Users
john, jack, jill :: Simple User'
john = User' (Identity "john") (Identity (Mail "[email protected]"))
jack = User' (Identity "jack") (Identity (Mail "[email protected]"))
jill = User' (Identity "jill") (Identity (Mail "[email protected]"))

-- let's write a diff changing the name of the first user:
exDiff :: Diff CoupleOfUsers'
exDiff = CoupleOfUsers' (dj $ User' (dj "newName") dn) dn
where
dj = Difference . Just
dn = Difference Nothing

-- Could this difference be computed automatically?
diffUser :: Simple User' -> Simple User' -> Diff User'
diffUser (User' (Identity n1) (Identity m1)) (User' (Identity n2) (Identity m2)) =
User' (if n1 == n2 then Difference Nothing else Difference (Just n2))
(if m1 == m2 then Difference Nothing else Difference (Just m2))

diffCouple :: Simple CoupleOfUsers' -> Simple CoupleOfUsers' -> Diff CoupleOfUsers'
diffCouple (CoupleOfUsers' (Identity a1) (Identity b1)) (CoupleOfUsers' (Identity a2) (Identity b2)) =
CoupleOfUsers' (if a1 == a2 then Difference Nothing else Difference (Just $ diffUser a1 a2))
(if b1 == b2 then Difference Nothing else Difference (Just $ diffUser b1 b2))

-- This behavior should be abstracted in a typeclass.
37 changes: 37 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,37 @@
{-# LANGUAGE DataKinds, OverloadedStrings, TypeFamilies, TypeOperators #-}

module MockAPI
( module MockAPI.Permission
, module MockAPI.RoleAttributes
, module MockAPI.Roles
, module MockAPI.User
, module MockAPI.Shaped
, module MockAPI
) where

import Servant.API
import Servant.Router

import MockAPI.Permission
import MockAPI.RoleAttributes
import MockAPI.Roles
import MockAPI.User
import MockAPI.Shaped
import Servant.HTML.Blaze
import Text.Blaze.Html4.Transitional (Html)

type MockApi = --"server" :>
("delete" :> Capture "role" RoleName :> Capture "user" User :> Delete '[JSON] NoContent
:<|> "add" :> Capture "role" RoleName :> ReqBody '[JSON] RoleAttributes :> Put '[JSON] NoContent
:<|> "roles" :> Get '[JSON] Roles
:<|> Raw)

type Navigation = "overview" :> View
:<|> "edit" :> Capture "roleName" RoleName :> View
:<|> "dog" :> Capture "age" Int :> View
:<|> "cat" :> View

type NavigationServer = ViewTransform Navigation (Get '[HTML] Html)

type WholeApi = NavigationServer
:<|> MockApi
75 changes: 75 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI/Permission.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,75 @@
{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}

module MockAPI.Permission where

import MockAPI.Prelude

-- A permission can be a permission in several ambiti

data Permission = PP ProductPermission | OP OrderPermission | UP UserPermission
deriving (Show, Read, Eq, Ord, Generic)

data ProductPermission
= ViewAllProductDetails
| EditProdTextualContent
| EditProdPhotos
| EditProdProperties
| EditProdPrice
deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)

data OrderPermission
= ViewAllOrderDetails
| CreateOrder
| EditOrder
| ApplyDiscounts
| CancelOrder
| ChangeOrderContactDetails
deriving (Show, Eq, Read, Ord, Generic, Bounded, Enum)

data UserPermission
= ViewUserDetails
| EditUserDetails
| ChangeUserRole
deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)

-- Generated JSON instances

instance ToJSON Permission
instance FromJSON Permission

instance ToJSON ProductPermission
instance FromJSON ProductPermission
instance ToJSON OrderPermission
instance FromJSON OrderPermission
instance ToJSON UserPermission
instance FromJSON UserPermission

-- We generate a class used to display a meaningful label to the user:

class UserLabel a where
toUserLabel :: a -> Text

instance UserLabel ProductPermission where
toUserLabel ViewAllProductDetails = "View all product details"
toUserLabel EditProdTextualContent = "Edit product textual content"
toUserLabel EditProdPhotos = "Edit product photos"
toUserLabel EditProdProperties = "Edit product properties"
toUserLabel EditProdPrice = "Edit product price "

instance UserLabel OrderPermission where
toUserLabel ViewAllOrderDetails = "View all order details"
toUserLabel CreateOrder = "Create a new order"
toUserLabel EditOrder = "Edit an existing order (not created by self)"
toUserLabel ApplyDiscounts = "Apply special discounts to orders"
toUserLabel CancelOrder = "Cancel an order"
toUserLabel ChangeOrderContactDetails = "Change contact details in an order"

instance UserLabel UserPermission where
toUserLabel ViewUserDetails = "View user details"
toUserLabel EditUserDetails = "Edit some other user's details"
toUserLabel ChangeUserRole = "Change roles assigned to a user"

instance UserLabel Permission where
toUserLabel (PP p) = toUserLabel p
toUserLabel (OP p) = toUserLabel p
toUserLabel (UP p) = toUserLabel p
15 changes: 15 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI/Prelude.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,15 @@
module MockAPI.Prelude
( module Data.Aeson
, module Control.Lens
, module Control.Lens.Wrapped
, module Data.Set
, module Data.Text
, module GHC.Generics
) where

import Control.Lens (makeLenses, iso)
import Control.Lens.Wrapped
import Data.Aeson (FromJSON, ToJSON)
import Data.Set (Set)
import Data.Text (Text)
import GHC.Generics
21 changes: 21 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI/RoleAttributes.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,21 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}

module MockAPI.RoleAttributes where

import MockAPI.Prelude
import MockAPI.Permission
import MockAPI.User

data RoleAttributes = RoleAttributes
{ _rolePermission :: Set Permission
, _roleAssociatedUsers :: Set User
} deriving (Show, Read, Eq, Ord, Generic)

emptyRoleAttributes :: RoleAttributes
emptyRoleAttributes = RoleAttributes mempty mempty

makeLenses ''RoleAttributes

instance ToJSON RoleAttributes
instance FromJSON RoleAttributes
21 changes: 21 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI/Roles.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,21 @@
{-# LANGUAGE DeriveGeneric, TypeFamilies #-}

module MockAPI.Roles where

import MockAPI.Prelude

import MockAPI.RoleAttributes

import Data.Map (Map)
import qualified Data.Map as Map

type RoleName = Text

newtype Roles = Roles { unRoles :: Map RoleName RoleAttributes } deriving (Show, Read, Eq, Ord, Generic)

instance Wrapped Roles where
type Unwrapped Roles = Map RoleName RoleAttributes
_Wrapped' = iso unRoles Roles

instance ToJSON Roles
instance FromJSON Roles
16 changes: 16 additions & 0 deletions UI/ReflexFRP/mockUsersRoles/mockAPI/src/MockAPI/Shaped.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,16 @@
{-# LANGUAGE DataKinds, FlexibleContexts, FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}

module MockAPI.Shaped where
import Data.Text

data Shape = Info | Error | Validation

type family Field i a where
Field Info a = a
Field Error a = Maybe Text
Field Validation a = a -> Maybe Text

class Shaped a b | a -> b, b -> a where
toShape :: a -> b
fromShape :: b -> a
Loading