├── .gitignore
├── LICENSE
├── Makefile
├── Setup.hs
├── app
    └── Main.hs
├── default.nix
├── haskell-web-app.cabal
├── packages.nix
├── shell.nix
├── src
    ├── Api
    │   ├── Task.hs
    │   └── User.hs
    ├── App.hs
    ├── Database
    │   ├── Task.hs
    │   └── User.hs
    ├── Domain
    │   ├── Task.hs
    │   └── User.hs
    ├── Example.hs
    ├── Models
    │   ├── Task.hs
    │   └── User.hs
    └── Types.hs
└── test
    ├── Domain
        └── UserSpec.hs
    └── Spec.hs


/.gitignore:
--------------------------------------------------------------------------------
1 | dist-newstyle
2 | .ghc.environment.*
3 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2018, Brian Jones
 2 | 
 3 | All rights reserved.
 4 | 
 5 | Redistribution and use in source and binary forms, with or without
 6 | modification, are permitted provided that the following conditions are met:
 7 | 
 8 |     * Redistributions of source code must retain the above copyright
 9 |       notice, this list of conditions and the following disclaimer.
10 | 
11 |     * Redistributions in binary form must reproduce the above
12 |       copyright notice, this list of conditions and the following
13 |       disclaimer in the documentation and/or other materials provided
14 |       with the distribution.
15 | 
16 |     * Neither the name of Brian Jones nor the names of other
17 |       contributors may be used to endorse or promote products derived
18 |       from this software without specific prior written permission.
19 | 
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 | 


--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | build:
2 | 	nix-shell --run "cabal new-build"
3 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | 
3 | --------------------------------------------------------------------------------
4 | import App
5 | --------------------------------------------------------------------------------
6 | 
7 | main :: IO ()
8 | main = exec
9 | 


--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
 1 | { compiler ? "ghc844" }:
 2 | 
 3 | let
 4 |   pkgs = import <nixpkgs> { };
 5 | 
 6 |   haskellPackages = pkgs.haskell.packages.${compiler};
 7 | 
 8 |   drv = haskellPackages.callPackage ./packages.nix { };
 9 | in
10 |   drv
11 | 


--------------------------------------------------------------------------------
/haskell-web-app.cabal:
--------------------------------------------------------------------------------
 1 | -- Initial freer-experiment.cabal generated by cabal init.  For further
 2 | -- documentation, see http://haskell.org/cabal/users-guide/
 3 | 
 4 | name:                haskell-web-app
 5 | version:             0.1.0.0
 6 | -- synopsis:
 7 | -- description:
 8 | license:             BSD3
 9 | license-file:        LICENSE
10 | author:              Brian Jones
11 | maintainer:          bcj@alasconnect.com
12 | -- copyright:
13 | -- category:
14 | build-type:          Simple
15 | cabal-version:       >=1.10
16 | 
17 | library
18 |   exposed-modules:     App
19 |                      , Api.User
20 |                      , Api.Task
21 |                      , Database.Task
22 |                      , Database.User
23 |                      , Domain.Task
24 |                      , Domain.User
25 |                      , Models.Task
26 |                      , Models.User
27 |                      , Types
28 |   -- other-modules:
29 |   -- other-extensions:
30 |   build-depends:       aeson
31 |                      , base
32 |                      , containers
33 |                      , mtl
34 |                      , servant
35 |                      , servant-server
36 |                      , tagged
37 |                      , text
38 |                      , wai
39 |                      , warp
40 |   hs-source-dirs:      src
41 |   default-language:    Haskell2010
42 |   ghc-options:         -O0
43 | 
44 | executable streamly-experiment
45 |   main-is:             Main.hs
46 |   -- other-modules:
47 |   -- other-extensions:
48 |   build-depends:       base
49 |                      , haskell-web-app
50 |   hs-source-dirs:      app
51 |   default-language:    Haskell2010
52 |   ghc-options:         -O0
53 | 
54 | test-suite spec
55 |   type:                 exitcode-stdio-1.0
56 |   main-is:              Spec.hs
57 | --  other-modules:
58 |   hs-source-dirs:       test
59 |   ghc-options:          -threaded -Wall
60 |   build-depends:        base
61 |                       , hspec == 2.*
62 |   default-language:     Haskell2010
63 | --  default-extensions:
64 | 


--------------------------------------------------------------------------------
/packages.nix:
--------------------------------------------------------------------------------
 1 | { mkDerivation, aeson, base, containers, hspec, mtl, servant
 2 | , servant-server, stdenv, streamly, tagged, text, wai, warp
 3 | }:
 4 | mkDerivation {
 5 |   pname = "streamly-experiment";
 6 |   version = "0.1.0.0";
 7 |   src = ./.;
 8 |   isLibrary = true;
 9 |   isExecutable = true;
10 |   libraryHaskellDepends = [
11 |     aeson base containers mtl servant servant-server streamly tagged
12 |     text wai warp
13 |   ];
14 |   executableHaskellDepends = [ base ];
15 |   testHaskellDepends = [ base hspec ];
16 |   license = stdenv.lib.licenses.bsd3;
17 | }
18 | 


--------------------------------------------------------------------------------
/shell.nix:
--------------------------------------------------------------------------------
1 | { compiler ? "ghc844" }:
2 | 
3 | (import ./. { inherit compiler; }).env
4 | 


--------------------------------------------------------------------------------
/src/Api/Task.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DataKinds #-}
 2 | {-# LANGUAGE TypeOperators #-}
 3 | 
 4 | module Api.Task where
 5 | 
 6 | --------------------------------------------------------------------------------
 7 | import Control.Monad.IO.Class
 8 | import Data.Proxy
 9 | import Servant
10 | --------------------------------------------------------------------------------
11 | import qualified Database.Task as DT
12 | import Domain.Task
13 | import Models.Task (Task, TaskId)
14 | --------------------------------------------------------------------------------
15 | 
16 | type GetTasksApi
17 |   = Get '[JSON] [Task]
18 | 
19 | type GetTaskApi
20 |   =  Capture "task_id" TaskId
21 |   :> Get '[JSON] (Maybe Task)
22 | 
23 | type CreateTaskApi
24 |   =  ReqBody '[JSON] Task
25 |   :> Post '[JSON] Task
26 | 
27 | type UpdateTaskApi
28 |   =  ReqBody '[JSON] Task
29 |   :> Put '[JSON] NoContent
30 | 
31 | type DeleteTaskApi
32 |   =  Capture "task_id" TaskId
33 |   :> Delete '[JSON] NoContent
34 | 
35 | type TaskApi
36 |   =  "api"
37 |   :> "v1"
38 |   :> "tasks"
39 |   :> (    GetTasksApi
40 |      :<|> GetTaskApi
41 |      :<|> CreateTaskApi
42 |      :<|> UpdateTaskApi
43 |      :<|> DeleteTaskApi
44 |      )
45 | 
46 | tasksApi :: Proxy TaskApi
47 | tasksApi = Proxy
48 | 
49 | tasksServer :: MonadIO m => ServerT TaskApi m
50 | tasksServer =
51 |        tasksGet
52 |   :<|> taskGet
53 |   :<|> taskCreate
54 |   :<|> taskUpdate
55 |   :<|> taskDelete
56 | 
57 | tasksGet :: MonadIO m => m [Task]
58 | tasksGet =
59 |   getTasks DT.getTasks
60 | 
61 | taskGet :: MonadIO m => TaskId -> m (Maybe Task)
62 | taskGet tid =
63 |   getTask DT.getTask tid
64 | 
65 | taskCreate :: MonadIO m => Task -> m Task
66 | taskCreate t =
67 |   createTask DT.createTask t
68 | 
69 | taskUpdate :: MonadIO m => Task -> m NoContent
70 | taskUpdate t = do
71 |   updateTask DT.updateTask t
72 |   return NoContent
73 | 
74 | taskDelete :: MonadIO m => TaskId -> m NoContent
75 | taskDelete tid = do
76 |   deleteTask DT.deleteTask tid
77 |   return NoContent
78 | 


--------------------------------------------------------------------------------
/src/Api/User.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DataKinds #-}
  2 | {-# LANGUAGE FlexibleContexts #-}
  3 | {-# LANGUAGE TypeOperators #-}
  4 | 
  5 | module Api.User where
  6 | 
  7 | --------------------------------------------------------------------------------
  8 | import Control.Monad.Reader
  9 | import Control.Monad.IO.Class
 10 | import Data.Proxy
 11 | import Servant
 12 | --------------------------------------------------------------------------------
 13 | import qualified Database.User as DU
 14 | import qualified Database.Task as DT
 15 | import Domain.Task
 16 | import Domain.User
 17 | import Models.Task (Task)
 18 | import Models.User (User, UserId)
 19 | import Types
 20 | --------------------------------------------------------------------------------
 21 | 
 22 | type GetUsersApi
 23 |   = Get '[JSON] [User]
 24 | 
 25 | type GetUserApi
 26 |   =  Capture "user_id" UserId
 27 |   :> Get '[JSON] (Maybe User)
 28 | 
 29 | type CreateUserApi
 30 |   =  ReqBody '[JSON] User
 31 |   :> Post '[JSON] User
 32 | 
 33 | type UpdateUserApi
 34 |   =  ReqBody '[JSON] User
 35 |   :> Put '[JSON] NoContent
 36 | 
 37 | type DeleteUserApi
 38 |   =  Capture "user_id" UserId
 39 |   :> Delete '[JSON] NoContent
 40 | 
 41 | type GetUserTasksApi
 42 |   =  Capture "user_id" UserId
 43 |   :> Get '[JSON] [Task]
 44 | 
 45 | type GetUserAndTasksApi
 46 |   =  "tasks"
 47 |   :> Capture "user_id" UserId
 48 |   :> Get '[JSON] (Maybe User, [Task])
 49 | 
 50 | type UserApi
 51 |   =  "api"
 52 |   :> "v1"
 53 |   :> "users"
 54 |   :> (    GetUsersApi
 55 |      :<|> GetUserApi
 56 |      :<|> CreateUserApi
 57 |      :<|> UpdateUserApi
 58 |      :<|> DeleteUserApi
 59 |      :<|> GetUserTasksApi
 60 |      :<|> GetUserAndTasksApi
 61 |      )
 62 | 
 63 | usersApi :: Proxy UserApi
 64 | usersApi = Proxy
 65 | 
 66 | usersServer :: (MonadIO m, MonadReader AppContext m) => ServerT UserApi m
 67 | usersServer =
 68 |        usersGet
 69 |   :<|> userGet
 70 |   :<|> userCreate
 71 |   :<|> userUpdate
 72 |   :<|> userDelete
 73 |   :<|> userTasks
 74 |   :<|> userAndTasks
 75 | 
 76 | usersGet :: MonadIO m => m [User]
 77 | usersGet =
 78 |   getUsers DU.getUsers
 79 | 
 80 | userGet :: MonadIO m => UserId -> m (Maybe User)
 81 | userGet uid =
 82 |   getUser DU.getUser uid
 83 | 
 84 | userCreate :: MonadIO m => User -> m User
 85 | userCreate u =
 86 |   createUser DU.createUser u
 87 | 
 88 | userUpdate :: MonadIO m => User -> m NoContent
 89 | userUpdate u = do
 90 |   updateUser DU.updateUser u
 91 |   return NoContent
 92 | 
 93 | userDelete :: MonadIO m => UserId -> m NoContent
 94 | userDelete uid = do
 95 |   deleteUser DU.deleteUser uid
 96 |   return NoContent
 97 | 
 98 | userTasks :: MonadIO m => UserId -> m [Task]
 99 | userTasks uid =
100 |   getUserTasks DT.getUserTasks uid
101 | 
102 | userAndTasks :: (MonadIO m, MonadReader AppContext m)
103 |   => UserId -> m (Maybe User, [Task])
104 | userAndTasks uid = do
105 |   ctx <- ask
106 |   u <- getUser DU.getUser uid
107 |   ts <- getUserTasks DT.getUserTasks uid
108 |   return (u, ts)
109 | 


--------------------------------------------------------------------------------
/src/App.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE ConstraintKinds #-}
 2 | {-# LANGUAGE DataKinds #-}
 3 | {-# LANGUAGE FlexibleContexts #-}
 4 | {-# LANGUAGE TypeOperators #-}
 5 | 
 6 | module App where
 7 | 
 8 | --------------------------------------------------------------------------------
 9 | import Control.Monad.Reader
10 | import Control.Monad.IO.Class
11 | import qualified Data.Map as Map
12 | import Data.Proxy
13 | import Network.Wai
14 | import qualified Network.Wai.Handler.Warp as W
15 | import Servant
16 | --------------------------------------------------------------------------------
17 | import Api.Task
18 | import Api.User
19 | import Types
20 | --------------------------------------------------------------------------------
21 | 
22 | type FullApi =
23 |        UserApi
24 |   :<|> TaskApi
25 | 
26 | fullApi :: Proxy FullApi
27 | fullApi = Proxy
28 | 
29 | fullApiServer :: (MonadIO m, MonadReader AppContext m) => ServerT FullApi m
30 | fullApiServer =
31 |   usersServer :<|> tasksServer
32 | 
33 | handler :: App a -> Handler a
34 | handler =
35 |   flip runReaderT (AppContext FakeConn) . runApp
36 | 
37 | server :: Server FullApi
38 | server =
39 |   hoistServer fullApi handler fullApiServer
40 | 
41 | app :: Application
42 | app =
43 |   serve fullApi server
44 | 
45 | exec :: IO ()
46 | exec =
47 |   W.run 8080 app
48 | 


--------------------------------------------------------------------------------
/src/Database/Task.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleContexts #-}
 2 | 
 3 | module Database.Task where
 4 | 
 5 | --------------------------------------------------------------------------------
 6 | import Control.Monad.IO.Class
 7 | --------------------------------------------------------------------------------
 8 | import Models.Task
 9 | import Models.User (UserId)
10 | import Types
11 | --------------------------------------------------------------------------------
12 | 
13 | getTasks :: MonadIO m => m [Task]
14 | getTasks = undefined
15 | 
16 | getTask :: MonadIO m => TaskId -> m (Maybe Task)
17 | getTask = undefined
18 | 
19 | createTask :: MonadIO m => Task -> m Task
20 | createTask = undefined
21 | 
22 | updateTask :: MonadIO m => Task -> m ()
23 | updateTask = undefined
24 | 
25 | deleteTask :: MonadIO m => TaskId -> m ()
26 | deleteTask = undefined
27 | 
28 | getUserTasks :: MonadIO m => UserId -> m [Task]
29 | getUserTasks = undefined
30 | 


--------------------------------------------------------------------------------
/src/Database/User.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE FlexibleInstances #-}
 2 | 
 3 | module Database.User where
 4 | 
 5 | --------------------------------------------------------------------------------
 6 | import Control.Monad.IO.Class
 7 | --------------------------------------------------------------------------------
 8 | import Models.User
 9 | import Types
10 | --------------------------------------------------------------------------------
11 | 
12 | getUsers :: MonadIO m => m [User]
13 | getUsers = undefined
14 | 
15 | getUser :: MonadIO m => UserId -> m (Maybe User)
16 | getUser = undefined
17 | 
18 | createUser :: MonadIO m => User -> m User
19 | createUser = undefined
20 | 
21 | updateUser :: MonadIO m => User -> m ()
22 | updateUser = undefined
23 | 
24 | deleteUser :: MonadIO m => UserId -> m ()
25 | deleteUser = undefined
26 | 


--------------------------------------------------------------------------------
/src/Domain/Task.hs:
--------------------------------------------------------------------------------
 1 | module Domain.Task where
 2 | 
 3 | --------------------------------------------------------------------------------
 4 | import Models.Task (Task, TaskId)
 5 | import Models.User (UserId)
 6 | import Types
 7 | --------------------------------------------------------------------------------
 8 | 
 9 | getTasks :: Monad m
10 |   => m [Task]
11 |   -> m [Task]
12 | getTasks f = f
13 | 
14 | getTask :: Monad m
15 |   => (TaskId -> m (Maybe Task))
16 |   -> TaskId
17 |   -> m (Maybe Task)
18 | getTask f tid = f tid
19 | 
20 | createTask :: Monad m
21 |   => (Task -> m Task)
22 |   -> Task
23 |   -> m Task
24 | createTask f t = f t
25 | 
26 | updateTask :: Monad m
27 |   => (Task -> m ())
28 |   -> Task
29 |   -> m ()
30 | updateTask f t = f t
31 | 
32 | deleteTask :: Monad m
33 |   => (TaskId -> m ())
34 |   -> TaskId
35 |   -> m ()
36 | deleteTask f tid = f tid
37 | 
38 | getUserTasks :: Monad m
39 |   => (UserId -> m [Task])
40 |   -> UserId
41 |   -> m [Task]
42 | getUserTasks f uid = f uid
43 | 


--------------------------------------------------------------------------------
/src/Domain/User.hs:
--------------------------------------------------------------------------------
 1 | module Domain.User where
 2 | 
 3 | --------------------------------------------------------------------------------
 4 | import Models.User (User, UserId)
 5 | import Types
 6 | --------------------------------------------------------------------------------
 7 | 
 8 | getUsers :: Monad m
 9 |   => m [User]
10 |   -> m [User]
11 | getUsers f = f
12 | 
13 | getUser :: Monad m
14 |   => (UserId -> m (Maybe User))
15 |   -> UserId
16 |   -> m (Maybe User)
17 | getUser f uid = f uid
18 | 
19 | createUser :: Monad m
20 |   => (User -> m User)
21 |   -> User
22 |   -> m User
23 | createUser f u = f u
24 | 
25 | updateUser :: Monad m
26 |   => (User -> m ())
27 |   -> User
28 |   -> m ()
29 | updateUser f u = f u
30 | 
31 | deleteUser :: Monad m
32 |   => (UserId -> m ())
33 |   -> UserId
34 |   -> m ()
35 | deleteUser f uid = f uid
36 | 


--------------------------------------------------------------------------------
/src/Example.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE DataKinds #-}
  2 | {-# LANGUAGE FlexibleContexts #-}
  3 | {-# LANGUAGE GADTs #-}
  4 | {-# LANGUAGE LambdaCase #-}
  5 | {-# LANGUAGE OverloadedStrings #-}
  6 | {-# LANGUAGE RankNTypes #-}
  7 | {-# LANGUAGE TypeOperators #-}
  8 | 
  9 | module Example where
 10 | 
 11 | --------------------------------------------------------------------------------
 12 | import Control.Monad.Freer
 13 | import Control.Monad.Freer.State
 14 | import Data.Map (Map)
 15 | import qualified Data.Map as Map
 16 | import Data.Text (Text)
 17 | --------------------------------------------------------------------------------
 18 | 
 19 | data Counter r where
 20 |   Val :: Counter Int
 21 |   Inc :: Int -> Counter ()
 22 |   Dec :: Int -> Counter ()
 23 | 
 24 | val :: Member Counter effs => Eff effs Int
 25 | val = send Val
 26 | 
 27 | inc :: Member Counter effs => Int -> Eff effs ()
 28 | inc = send . Inc
 29 | 
 30 | dec :: Member Counter effs => Int -> Eff effs ()
 31 | dec = send . Dec
 32 | 
 33 | runCounterInMemory :: Int -> Eff (Counter ': effs) ~> Eff effs
 34 | runCounterInMemory i = evalState i . go
 35 |   where
 36 |     go :: Eff (Counter ': effs) ~> Eff (State Int ': effs)
 37 |     go = reinterpret $ \case
 38 |       Val   -> get
 39 |       Inc v -> modify (\a -> a + v)
 40 |       Dec v -> modify (\a -> a - v)
 41 | 
 42 | data User = User Text Text deriving Show
 43 | 
 44 | data Mapper r where
 45 |   UserAll :: Mapper [User]
 46 |   UserGet :: Text -> Mapper (Maybe User)
 47 |   UserAdd :: Text -> User -> Mapper ()
 48 |   UserDel :: Text -> Mapper ()
 49 | 
 50 | userAll :: Member Mapper effs => Eff effs [User]
 51 | userAll = send UserAll
 52 | 
 53 | userGet :: Member Mapper effs => Text -> Eff effs (Maybe User)
 54 | userGet = send . UserGet
 55 | 
 56 | userAdd :: Member Mapper effs => Text -> User -> Eff effs ()
 57 | userAdd k v = send $ UserAdd k v
 58 | 
 59 | userDel :: Member Mapper effs => Text -> Eff effs ()
 60 | userDel = send . UserDel
 61 | 
 62 | type Vdb = Map Text User
 63 | 
 64 | runMapperInMemory :: Vdb -> Eff (Mapper ': effs) ~> Eff effs
 65 | runMapperInMemory vdb = evalState vdb . go
 66 |   where
 67 |     go :: Eff (Mapper ': effs) ~> Eff (State Vdb ': effs)
 68 |     go = reinterpret $ \case
 69 |       UserAll     -> get >>= \db -> return . Map.elems $ (db :: Vdb)
 70 |       UserGet k   -> get >>= return . Map.lookup k
 71 |       UserAdd k v -> modify (\db -> Map.insert k v db :: Vdb)
 72 |       UserDel k   -> modify (\db -> Map.delete k db :: Vdb)
 73 | 
 74 | counterApp :: Members '[Counter] effs => Eff effs Int
 75 | counterApp = do
 76 |   inc 10
 77 |   dec 3
 78 |   inc 5
 79 |   dec 15
 80 |   dec 1
 81 |   val
 82 | 
 83 | mapperApp :: Members '[IO, Mapper] effs => Eff effs [User]
 84 | mapperApp = do
 85 |   userAdd "luke" (User "Luke" "Cage")
 86 |   userAdd "jess" (User "Jessica" "Jones")
 87 |   userAdd "matt" (User "Matt" "Murdock")
 88 |   luke <- userGet "luke"
 89 |   send $ print luke
 90 |   userDel "jess"
 91 |   jess <- userGet "jess"
 92 |   send $ print jess
 93 |   userAll
 94 | 
 95 | allApp :: Members '[IO, Mapper, Counter] effs => Eff effs (Int, [User])
 96 | allApp = do
 97 |   userAdd "luke" (User "Luke" "Cage")
 98 |   userAdd "jess" (User "Jessica" "Jones")
 99 |   inc 10
100 |   userAdd "matt" (User "Matt" "Murdock")
101 |   luke <- userGet "luke"
102 |   inc 20
103 |   dec 5
104 |   send $ print luke
105 |   userDel "jess"
106 |   jess <- userGet "jess"
107 |   dec 13
108 |   send $ print jess
109 |   us <- userAll
110 |   n <- val
111 |   return (n, us)
112 | 
113 | exec :: IO ()
114 | exec = do
115 |   -- counter
116 |   putStrLn "--------------------"
117 |   putStrLn "counter"
118 |   putStrLn "--------------------"
119 |   let v = run . runCounterInMemory 0 $ counterApp
120 |   putStrLn $ show v
121 | 
122 |   -- mapper
123 |   putStrLn "--------------------"
124 |   putStrLn "mapper"
125 |   putStrLn "--------------------"
126 |   m <- runM . runMapperInMemory Map.empty $ mapperApp
127 |   putStrLn $ show m
128 | 
129 |   -- combined
130 |   putStrLn "--------------------"
131 |   putStrLn "combined"
132 |   putStrLn "--------------------"
133 |   (n, us) <- runM . runMapperInMemory Map.empty . runCounterInMemory 0 $ allApp
134 |   print n
135 |   print us
136 | 


--------------------------------------------------------------------------------
/src/Models/Task.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveGeneric #-}
 2 | {-# LANGUAGE FlexibleInstances #-}
 3 | {-# LANGUAGE TypeSynonymInstances #-}
 4 | 
 5 | module Models.Task where
 6 | 
 7 | --------------------------------------------------------------------------------
 8 | import Data.Aeson
 9 | import Data.Tagged (Tagged(..), untag)
10 | import Data.Text (Text, pack)
11 | import Data.Text.Read (decimal)
12 | import GHC.Generics
13 | import Servant.API
14 | --------------------------------------------------------------------------------
15 | import Models.User (UserId)
16 | --------------------------------------------------------------------------------
17 | 
18 | data TaskIdTag
19 | type TaskId = Tagged TaskIdTag Int
20 | 
21 | instance ToHttpApiData TaskId where
22 |   toUrlPiece = pack . show . untag
23 | instance FromHttpApiData TaskId where
24 |   parseUrlPiece t =
25 |     case decimal t of
26 |       Right (v, _) -> Right . mkTaskId . fromInteger $ v
27 |       Left e       -> Left . pack $ e
28 | 
29 | mkTaskId :: Int -> TaskId
30 | mkTaskId = Tagged
31 | 
32 | data Task
33 |   = Task
34 |   { taskId :: TaskId
35 |   , userId :: UserId
36 |   , name   :: Text
37 |   } deriving (Generic, Show)
38 | 
39 | instance ToJSON Task
40 | instance FromJSON Task
41 | 
42 | mkTask :: UserId -> Text -> Task
43 | mkTask = Task 0
44 | 


--------------------------------------------------------------------------------
/src/Models/User.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveGeneric #-}
 2 | {-# LANGUAGE FlexibleInstances #-}
 3 | {-# LANGUAGE TypeSynonymInstances #-}
 4 | 
 5 | module Models.User where
 6 | 
 7 | --------------------------------------------------------------------------------
 8 | import Data.Aeson
 9 | import Data.Tagged (Tagged(..), untag)
10 | import Data.Text (Text, pack)
11 | import Data.Text.Read (decimal)
12 | import GHC.Generics
13 | import Servant.API
14 | --------------------------------------------------------------------------------
15 | 
16 | data UserIdTag
17 | type UserId = Tagged UserIdTag Int
18 | 
19 | instance ToHttpApiData UserId where
20 |   toUrlPiece = pack . show . untag
21 | instance FromHttpApiData UserId where
22 |   parseUrlPiece t =
23 |     case decimal t of
24 |       Right (v, _) -> Right . mkUserId . fromInteger $ v
25 |       Left e       -> Left . pack $ e
26 | 
27 | mkUserId :: Int -> UserId
28 | mkUserId = Tagged
29 | 
30 | data User
31 |   = User
32 |   { userId :: UserId
33 |   , name   :: Text
34 |   } deriving (Generic, Show)
35 | 
36 | instance ToJSON User
37 | instance FromJSON User
38 | 
39 | mkUser :: Text -> User
40 | mkUser = User 0
41 | 


--------------------------------------------------------------------------------
/src/Types.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 2 | 
 3 | module Types where
 4 | 
 5 | --------------------------------------------------------------------------------
 6 | import Control.Monad.Reader
 7 | import Control.Monad.IO.Class
 8 | import Servant
 9 | --------------------------------------------------------------------------------
10 | 
11 | data FakeConn = FakeConn
12 | data AppContext
13 |   = AppContext
14 |   { conn :: FakeConn -- in a real system this would be a pool
15 |   }
16 | 
17 | newtype App a = App { runApp :: ReaderT AppContext Handler a }
18 |   deriving (Functor, Applicative, Monad, MonadReader AppContext, MonadIO)
19 | 


--------------------------------------------------------------------------------
/test/Domain/UserSpec.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
 2 | 
 3 | module Domain.UserSpec where
 4 | 
 5 | -------------------------------------------------------------------------------
 6 | import Test.Hspec
 7 | -------------------------------------------------------------------------------
 8 | 
 9 | instance DomainUser (Writer [String]) where
10 |   getUsers = undefined
11 |   getUser = undefined
12 |   createUser = undefined
13 |   updateUser = undefined
14 |   deleteUser = undefined
15 | 
16 | spec :: Spec
17 | spec = parallel $ do
18 |   describe "DatabaseUser" $ do
19 |     it "getUsers" $ do
20 |       True `shouldBe` True
21 | 


--------------------------------------------------------------------------------
/test/Spec.hs:
--------------------------------------------------------------------------------
 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
 2 | 
 3 | -- **DO NOT ADD CODE TO THIS FILE**
 4 | 
 5 | -- The tests are using HSpec's auto discovery feature.
 6 | -- To Add a spec, just create a file with the same directory structure as the project.
 7 | -- The file name must end with Spec.hs.
 8 | -- The module must export a function called 'spec' with a return type of Spec.
 9 | -- https://hspec.github.io/hspec-discover.html
10 | 


--------------------------------------------------------------------------------