responsible/Examples/Conduit.idr at main · brainrake/responsible · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
module Examples.Conduit

import Http
import Control.App
import Control.App.Log
import Data.Maybe
import Data.List
import Data.Http.Request
import Language.JSON


hello : Has [ Context Request, Log ] e =>  Api e
hello = do
    r <- getRequest
    -- -- crash:
    -- logStr "Hello, Console!"
    pure $ ok $ "Hello, Http! " ++ r.path


nop : Api e
nop =
    pure $ ok "OK"


getComment : String -> String -> Api e
getComment slug id =
    pure $ ok  $ JObject [("slug", JString slug), ("id", JString id)]


getUser : String -> Api e
getUser userId =
    pure $ ok $ JString userId


getCurrentUser : Context Token e => Api e
getCurrentUser = do
    (MkToken str) <- getToken
    getUser str


api : Has
    [ Context Request
    , State Route String
    , Exception NoRoute
    , Log
    ] e => Api e
api = with Control.App.Http.Route.get do
     route "api" $ header (allowOrigin "*") $ concat
        [ route "hello" $
            hello
        , routes "users"
            [ post nop
            , route "login" $
                loginJwt
            ]
        , route "tags" $ get nop
        , authorized $ concat
            [ routes "user"
                [ get getCurrentUser
                , put nop
                ]
            , routes "profile"
                [ param $ \userId => concat
                    [ get nop
                    , routes "follow"
                        [ post nop
                        , delete nop
                        ]
                    ]
                ]
            , routes "articles"
                [ get nop
                , post nop
                , param $ \slug => concat
                    [ get nop
                    , put nop
                    , delete nop
                    , routes "comments"
                        [ get nop
                        , post nop
                        , param $ \id => concat
                            [ delete nop
                            , get $ getComment slug id
                            ]
                        ]
                    , routes "favorite"
                        [ post nop
                        , delete nop
                        ]
                    ]
                , route "feed" $
                    get nop
                ]
            ]
        ]


main : IO ()
main =
    run $ devServer "127.0.0.1:8000" api