11 | category: Web
12 | homepage: https://github.com/monadicsystems/okapi#readme
13 | bug-reports: https://github.com/monadicsystems/okapi/issues
14 | author: Monadic Systems LLC
15 | maintainer: tech@monadic.systems
16 | copyright: 2022 Monadic Systems LLC
17 | license: BSD-3-Clause
18 | license-file: LICENSE
19 | build-type: Simple
20 | extra-source-files:
21 | README.md
22 | ChangeLog.md
23 |
24 | source-repository head
25 | type: git
26 | location: https://github.com/monadicsystems/okapi
27 |
28 | library
29 | exposed-modules:
30 | Okapi
31 | Okapi.Middleware
32 | Okapi.Route.Pattern
33 | Okapi.Headers
34 | Okapi.Query
35 | Okapi.Body
36 | Okapi.App
37 | Okapi.Route
38 | Okapi.Response
39 | other-modules:
40 | Paths_okapi
41 | hs-source-dirs:
42 | src
43 | build-depends:
44 | aeson
45 | , base >=4.7 && <5
46 | , base64
47 | , binary
48 | , bytestring
49 | , case-insensitive
50 | , containers
51 | , cookie
52 | , extra
53 | , http-api-data
54 | , http-types
55 | , natural-transformation
56 | , network
57 | , pretty-simple
58 | , regex-tdfa
59 | , text
60 | , vault
61 | , wai
62 | , wai-extra
63 | , wai-logger
64 | , warp
65 | default-language: Haskell2010
66 |
67 | executable hello-world
68 | main-is: Main.hs
69 | hs-source-dirs:
70 | examples/hello-world
71 | build-depends:
72 | base
73 | , okapi
74 | , warp
75 | , wai
76 | , text
77 | , http-api-data
78 | , http-types
79 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
80 | default-language: Haskell2010
81 |
82 | executable calculator
83 | main-is: Main.hs
84 | hs-source-dirs:
85 | examples/calculator
86 | build-depends:
87 | base
88 | , okapi
89 | , warp
90 | , wai
91 | , text
92 | , http-api-data
93 | , http-types
94 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
95 | default-language: Haskell2010
96 |
97 | executable bookstore
98 | main-is: Main.hs
99 | hs-source-dirs:
100 | examples/bookstore
101 | build-depends:
102 | base
103 | , aeson
104 | , okapi
105 | , warp
106 | , wai
107 | , text
108 | , http-api-data
109 | , http-types
110 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
111 | default-language: Haskell2010
112 |
113 | executable tick
114 | main-is: Main.hs
115 | hs-source-dirs:
116 | examples/tick
117 | build-depends:
118 | base
119 | , okapi
120 | , warp
121 | , wai
122 | , text
123 | , http-api-data
124 | , http-types
125 | , wai-extra
126 | , binary
127 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
128 | default-language: Haskell2010
129 |
130 | test-suite okapi-test
131 | type: exitcode-stdio-1.0
132 | main-is: Spec.hs
133 | other-modules:
134 | Paths_okapi
135 | hs-source-dirs:
136 | test
137 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
138 | build-depends:
139 | base >=4.7 && <5
140 | , hspec
141 | , text
142 | default-language: Haskell2010
143 |
--------------------------------------------------------------------------------
/old/Query/Alternative.hs:
--------------------------------------------------------------------------------
1 | -- {-# LANGUAGE GADTs #-}
2 | -- {-# LANGUAGE ImportQualifiedPost #-}
3 | -- {-# LANGUAGE OverloadedRecordDot #-}
4 |
5 | -- module Okapi.Parser.Query.Alternative where
6 |
7 | -- import Data.Bifunctor qualified as Bifunctor
8 | -- import Data.ByteString qualified as BS
9 | -- import Data.List qualified as List
10 | -- import Data.Text qualified as Text
11 | -- import Data.Text.Encoding qualified as Text
12 | -- import Network.HTTP.Types qualified as HTTP
13 | -- import Web.HttpApiData qualified as Web
14 | -- import Network.Wai qualified as Wai
15 | -- import Network.Wai.Internal qualified as Wai
16 | -- import Okapi.Parser.Query.Operation qualified as Operation
17 | -- import Control.Applicative (Alternative(..))
18 | -- import Okapi.Tree qualified as Tree
19 |
20 | -- data Parser a where
21 | -- FMap :: (a -> b) -> Parser a -> Parser b
22 | -- Pure :: a -> Parser a
23 | -- Apply :: Parser (a -> b) -> Parser a -> Parser b
24 | -- Empty :: Parser a
25 | -- Or :: Parser a -> Parser a -> Parser a
26 | -- Optional :: Parser a -> Parser (Maybe a)
27 | -- Option :: a -> Parser a -> Parser a
28 | -- Operation :: Operation.Parser a -> Parser a
29 |
30 | -- instance Functor Parser where
31 | -- fmap = FMap
32 |
33 | -- instance Applicative Parser where
34 | -- pure = Pure
35 | -- (<*>) = Apply
36 |
37 | -- instance Alternative Parser where
38 | -- empty = Empty
39 | -- (<|>) = Or
40 |
41 | -- param :: Web.FromHttpApiData a => BS.ByteString -> Parser a
42 | -- param = Operation . Operation.Param
43 |
44 | -- flag :: BS.ByteString -> Parser ()
45 | -- flag = Operation . Operation.Flag
46 |
47 | -- optional :: Web.FromHttpApiData a => Parser a -> Parser (Maybe a)
48 | -- optional = Optional
49 |
50 | -- option :: Web.FromHttpApiData a => a -> Parser a -> Parser a
51 | -- option = Option
52 |
53 | -- eval ::
54 | -- Parser a ->
55 | -- Wai.Request ->
56 | -- (Either (Tree.Tree Operation.Error) a, Wai.Request)
57 | -- eval (FMap f opX) state = case eval opX state of
58 | -- (Left e, state') -> (Left e, state')
59 | -- (Right x, state') -> (Right $ f x, state')
60 | -- eval (Pure x) state = (Right x, state)
61 | -- eval (Apply opF opX) state = case eval opF state of
62 | -- (Right f, state') -> case eval opX state' of
63 | -- (Right x, state'') -> (Right $ f x, state'')
64 | -- (Left e, state'') -> (Left e, state'')
65 | -- (Left e, state') -> (Left e, state')
66 | -- eval Empty state = (Left Tree.Nil, state)
67 | -- eval (Or opA opB) state = case eval opA state of
68 | -- (Right a, state') -> (Right a, state')
69 | -- (Left l, state') -> case eval opB state' of
70 | -- (Right b, state'') -> (Right b, state'')
71 | -- (Left r, state'') -> (Left (l Tree.:|: r), state'')
72 | -- eval (Optional op) state = case op of
73 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
74 | -- (Right result, state') -> (Right $ Just result, state')
75 | -- (_, state') -> (Right Nothing, state')
76 | -- Operation flag@(Operation.Flag _) -> case Operation.eval flag state of
77 | -- (Right result, state') -> (Right $ Just result, state')
78 | -- (_, state') -> (Right Nothing, state')
79 | -- _ -> case eval op state of
80 | -- (Right result, state') -> (Right $ Just result, state')
81 | -- (Left err, state') -> (Left err, state')
82 | -- eval (Option def op) state = case op of
83 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
84 | -- (Right result, state') -> (Right result, state')
85 | -- (_, state') -> (Right def, state')
86 | -- Operation flag@(Operation.Flag _) -> case Operation.eval flag state of
87 | -- (Right result, state') -> (Right result, state')
88 | -- (_, state') -> (Right def, state')
89 | -- _ -> eval op state
90 | -- eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state
91 |
92 | -- class FromQuery a where
93 | -- parser :: Parser a
94 |
95 | -- parse :: FromQuery a => Wai.Request -> Either (Tree.Tree Operation.Error) a
96 | -- parse req = fst $ eval parser req
97 |
--------------------------------------------------------------------------------
/old/Body/Alternative.hs:
--------------------------------------------------------------------------------
1 | -- {-# LANGUAGE GADTs #-}
2 | -- {-# LANGUAGE ImportQualifiedPost #-}
3 | -- {-# LANGUAGE OverloadedRecordDot #-}
4 |
5 | -- module Okapi.Parser.Body.Alternative where
6 |
7 | -- import Data.Bifunctor qualified as Bifunctor
8 | -- import Data.ByteString qualified as BS
9 | -- import Data.List qualified as List
10 | -- import Data.Text qualified as Text
11 | -- import Data.Text.Encoding qualified as Text
12 | -- import Network.HTTP.Types qualified as HTTP
13 | -- import Web.HttpApiData qualified as Web
14 | -- import Network.Wai qualified as Wai
15 | -- import Network.Wai.Internal qualified as Wai
16 | -- import Okapi.Parser.Headers.Operation qualified as Operation
17 | -- import Control.Applicative (Alternative(..))
18 | -- import Okapi.Tree qualified as Tree
19 |
20 | -- data Parser a where
21 | -- FMap :: (a -> b) -> Parser a -> Parser b
22 | -- Pure :: a -> Parser a
23 | -- Apply :: Parser (a -> b) -> Parser a -> Parser b
24 | -- Empty :: Parser a
25 | -- Or :: Parser a -> Parser a -> Parser a
26 | -- Optional :: Parser a -> Parser (Maybe a)
27 | -- Option :: a -> Parser a -> Parser a
28 | -- Operation :: Operation.Parser a -> Parser a
29 |
30 | -- instance Functor Parser where
31 | -- fmap = FMap
32 |
33 | -- instance Applicative Parser where
34 | -- pure = Pure
35 | -- (<*>) = Apply
36 |
37 | -- instance Alternative Parser where
38 | -- empty = Empty
39 | -- (<|>) = Or
40 |
41 | -- param :: Web.FromHttpApiData a => HTTP.HeaderName -> Parser a
42 | -- param = Operation . Operation.Param
43 |
44 | -- cookie :: BS.ByteString -> Parser ()
45 | -- cookie = Operation . Operation.Cookie
46 |
47 | -- optional :: Web.FromHttpApiData a => Parser a -> Parser (Maybe a)
48 | -- optional = Optional
49 |
50 | -- option :: Web.FromHttpApiData a => a -> Parser a -> Parser a
51 | -- option = Option
52 |
53 | -- eval ::
54 | -- Parser a ->
55 | -- Wai.Request ->
56 | -- (Either (Tree.Tree Operation.Error) a, Wai.Request)
57 | -- eval (FMap f opX) state = case eval opX state of
58 | -- (Left e, state') -> (Left e, state')
59 | -- (Right x, state') -> (Right $ f x, state')
60 | -- eval (Pure x) state = (Right x, state)
61 | -- eval (Apply opF opX) state = case eval opF state of
62 | -- (Right f, state') -> case eval opX state' of
63 | -- (Right x, state'') -> (Right $ f x, state'')
64 | -- (Left e, state'') -> (Left e, state'')
65 | -- (Left e, state') -> (Left e, state')
66 | -- eval Empty state = (Left Tree.Nil, state)
67 | -- eval (Or opA opB) state = case eval opA state of
68 | -- (Right a, state') -> (Right a, state')
69 | -- (Left l, state') -> case eval opB state' of
70 | -- (Right b, state'') -> (Right b, state'')
71 | -- (Left r, state'') -> (Left (l Tree.:|: r), state'')
72 | -- eval (Optional op) state = case op of
73 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
74 | -- (Right result, state') -> (Right $ Just result, state')
75 | -- (_, state') -> (Right Nothing, state')
76 | -- Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of
77 | -- (Right result, state') -> (Right $ Just result, state')
78 | -- (_, state') -> (Right Nothing, state')
79 | -- _ -> case eval op state of
80 | -- (Right result, state') -> (Right $ Just result, state')
81 | -- (Left err, state') -> (Left err, state')
82 | -- eval (Option def op) state = case op of
83 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
84 | -- (Right result, state') -> (Right result, state')
85 | -- (_, state') -> (Right def, state')
86 | -- Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of
87 | -- (Right result, state') -> (Right result, state')
88 | -- (_, state') -> (Right def, state')
89 | -- _ -> eval op state
90 | -- eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state
91 |
92 | -- class FromQuery a where
93 | -- parser :: Parser a
94 |
95 | -- parse :: FromQuery a => Wai.Request -> Either (Tree.Tree Operation.Error) a
96 | -- parse req = fst $ eval parser req
97 |
--------------------------------------------------------------------------------
/old/Headers/Alternative.hs:
--------------------------------------------------------------------------------
1 | -- {-# LANGUAGE GADTs #-}
2 | -- {-# LANGUAGE ImportQualifiedPost #-}
3 | -- {-# LANGUAGE OverloadedRecordDot #-}
4 |
5 | -- module Okapi.Parser.Headers.Alternative where
6 |
7 | -- import Data.Bifunctor qualified as Bifunctor
8 | -- import Data.ByteString qualified as BS
9 | -- import Data.List qualified as List
10 | -- import Data.Text qualified as Text
11 | -- import Data.Text.Encoding qualified as Text
12 | -- import Network.HTTP.Types qualified as HTTP
13 | -- import Web.HttpApiData qualified as Web
14 | -- import Network.Wai qualified as Wai
15 | -- import Network.Wai.Internal qualified as Wai
16 | -- import Okapi.Parser.Headers.Operation qualified as Operation
17 | -- import Control.Applicative (Alternative(..))
18 | -- import Okapi.Tree qualified as Tree
19 |
20 | -- data Parser a where
21 | -- FMap :: (a -> b) -> Parser a -> Parser b
22 | -- Pure :: a -> Parser a
23 | -- Apply :: Parser (a -> b) -> Parser a -> Parser b
24 | -- Empty :: Parser a
25 | -- Or :: Parser a -> Parser a -> Parser a
26 | -- Optional :: Parser a -> Parser (Maybe a)
27 | -- Option :: a -> Parser a -> Parser a
28 | -- Operation :: Operation.Parser a -> Parser a
29 |
30 | -- instance Functor Parser where
31 | -- fmap = FMap
32 |
33 | -- instance Applicative Parser where
34 | -- pure = Pure
35 | -- (<*>) = Apply
36 |
37 | -- instance Alternative Parser where
38 | -- empty = Empty
39 | -- (<|>) = Or
40 |
41 | -- param :: Web.FromHttpApiData a => HTTP.HeaderName -> Parser a
42 | -- param = Operation . Operation.Param
43 |
44 | -- cookie :: BS.ByteString -> Parser ()
45 | -- cookie = Operation . Operation.Cookie
46 |
47 | -- optional :: Web.FromHttpApiData a => Parser a -> Parser (Maybe a)
48 | -- optional = Optional
49 |
50 | -- option :: Web.FromHttpApiData a => a -> Parser a -> Parser a
51 | -- option = Option
52 |
53 | -- eval ::
54 | -- Parser a ->
55 | -- Wai.Request ->
56 | -- (Either (Tree.Tree Operation.Error) a, Wai.Request)
57 | -- eval (FMap f opX) state = case eval opX state of
58 | -- (Left e, state') -> (Left e, state')
59 | -- (Right x, state') -> (Right $ f x, state')
60 | -- eval (Pure x) state = (Right x, state)
61 | -- eval (Apply opF opX) state = case eval opF state of
62 | -- (Right f, state') -> case eval opX state' of
63 | -- (Right x, state'') -> (Right $ f x, state'')
64 | -- (Left e, state'') -> (Left e, state'')
65 | -- (Left e, state') -> (Left e, state')
66 | -- eval Empty state = (Left Tree.Nil, state)
67 | -- eval (Or opA opB) state = case eval opA state of
68 | -- (Right a, state') -> (Right a, state')
69 | -- (Left l, state') -> case eval opB state' of
70 | -- (Right b, state'') -> (Right b, state'')
71 | -- (Left r, state'') -> (Left (l Tree.:|: r), state'')
72 | -- eval (Optional op) state = case op of
73 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
74 | -- (Right result, state') -> (Right $ Just result, state')
75 | -- (_, state') -> (Right Nothing, state')
76 | -- Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of
77 | -- (Right result, state') -> (Right $ Just result, state')
78 | -- (_, state') -> (Right Nothing, state')
79 | -- _ -> case eval op state of
80 | -- (Right result, state') -> (Right $ Just result, state')
81 | -- (Left err, state') -> (Left err, state')
82 | -- eval (Option def op) state = case op of
83 | -- Operation param@(Operation.Param _) -> case Operation.eval param state of
84 | -- (Right result, state') -> (Right result, state')
85 | -- (_, state') -> (Right def, state')
86 | -- Operation cookie@(Operation.Cookie _) -> case Operation.eval cookie state of
87 | -- (Right result, state') -> (Right result, state')
88 | -- (_, state') -> (Right def, state')
89 | -- _ -> eval op state
90 | -- eval (Operation op) state = Bifunctor.first (Bifunctor.first Tree.Leaf) $ Operation.eval op state
91 |
92 | -- class FromQuery a where
93 | -- parser :: Parser a
94 |
95 | -- parse :: FromQuery a => Wai.Request -> Either (Tree.Tree Operation.Error) a
96 | -- parse req = fst $ eval parser req
97 |
--------------------------------------------------------------------------------
/lib/examples/bookstore/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DataKinds #-}
2 | {-# LANGUAGE OverloadedStrings #-}
3 | {-# LANGUAGE TypeApplications #-}
4 | {-# LANGUAGE DuplicateRecordFields #-}
5 | {-# LANGUAGE DeriveAnyClass #-}
6 | {-# LANGUAGE DeriveGeneric #-}
7 |
8 | module Main where
9 |
10 | import qualified GHC.Generics as Generics
11 | import qualified Data.Aeson as Aeson
12 | import qualified Data.Text as Text
13 | import qualified Network.HTTP.Types as HTTP
14 | import qualified Network.Wai as Wai
15 | import qualified Network.Wai.Handler.Warp as Warp
16 | import Okapi.App
17 | import Okapi.Response
18 | import qualified Web.HttpApiData as Web
19 |
20 | -- Data types representing books, authors, genres, and user preferences
21 | data Book = Book
22 | { bookId :: Int
23 | , title :: Text.Text
24 | , authorId :: Int
25 | , genreId :: Int
26 | }
27 | deriving (Generics.Generic, Aeson.ToJSON, Show)
28 | data Author = Author
29 | { authorId :: Int
30 | , authorName :: Text.Text
31 | }
32 | deriving (Generics.Generic, Aeson.ToJSON, Show)
33 | data Genre = Genre
34 | { genreId :: Int
35 | , genreName :: Text.Text
36 | }
37 | deriving (Generics.Generic, Aeson.ToJSON, Show)
38 | data UserPreference = UserPreference
39 | { userId :: Int
40 | , bookId :: Int
41 | }
42 | deriving (Generics.Generic, Aeson.ToJSON, Show)
43 |
44 | -- API for listing books, authors, and genres
45 | bookstoreApi =
46 | choice
47 | [ lit "books"
48 | $ choice
49 | [ lit "list"
50 | . responder @200 @'[] @Aeson.Value @[Book]
51 | . method HTTP.GET id
52 | $ \ok _req ->
53 | return $ ok noHeaders [Book 1 "The Hobbit" 1 1, Book 2 "1984" 2 2]
54 | , lit "details"
55 | . param @Int
56 | . responder @200 @'[] @Aeson.Value @Book
57 | . responder @500 @'[] @Aeson.Value @Text.Text
58 | . method HTTP.GET id
59 | $ \bookId ok bookNotFound _req ->
60 | return $ case findBook bookId of
61 | Just book -> ok noHeaders book
62 | Nothing -> bookNotFound noHeaders "Book not found"
63 | ]
64 | , lit "authors"
65 | . responder @200 @'[] @Aeson.Value @[Author]
66 | . method HTTP.GET id
67 | $ \ok _req ->
68 | return $ ok noHeaders [Author 1 "J.R.R. Tolkien", Author 2 "George Orwell"]
69 | , lit "genres"
70 | . responder @200 @'[] @Aeson.Value @[Genre]
71 | . method HTTP.GET id
72 | $ \ok _req ->
73 | return $ ok noHeaders [Genre 1 "Fantasy", Genre 2 "Dystopian"]
74 | ]
75 |
76 | -- API for user preferences
77 | userApi =
78 | lit "user"
79 | $ choice
80 | [ lit "preferences"
81 | -- . authenticateUser -- Middleware for user authentication
82 | . param @Int
83 | . responder @200 @'[] @Aeson.Value @[Book]
84 | . responder @500 @'[] @Text.Text @Text.Text
85 | . method HTTP.GET id
86 | $ \userId ok userNotFound _req ->
87 | return $ case getUserPreferences userId of
88 | Just preferences -> ok noHeaders preferences
89 | Nothing -> userNotFound noHeaders "User not found"
90 | ]
91 |
92 | -- Combining the Bookstore and User APIs
93 | api = choice [bookstoreApi, userApi]
94 |
95 | -- Helper function to find a book by ID (replace with database query)
96 | findBook :: Int -> Maybe Book
97 | findBook 1 = Just $ Book 1 "The Hobbit" 1 1
98 | findBook 2 = Just $ Book 2 "1984" 2 2
99 | findBook _ = Nothing
100 |
101 | -- Helper function to get user preferences (replace with database query)
102 | getUserPreferences :: Int -> Maybe [Book]
103 | getUserPreferences userId
104 | | userId == 1 = Just [Book 1 "The Hobbit" 1 1]
105 | | userId == 2 = Just [Book 2 "1984" 2 2]
106 | | otherwise = Nothing
107 |
108 | -- Run the API on port 8009
109 | main :: IO ()
110 | main = Warp.run 8009 . withDefault api $ \req resp ->
111 | resp $ Wai.responseLBS HTTP.status404 [] "Not Found..."
--------------------------------------------------------------------------------
/docs/pages/syntax.css:
--------------------------------------------------------------------------------
1 | pre>code.sourceCode {
2 | white-space: pre;
3 | position: relative;
4 | }
5 |
6 | pre>code.sourceCode>span {
7 | display: inline-block;
8 | line-height: 1.25;
9 | }
10 |
11 | pre>code.sourceCode>span:empty {
12 | height: 1.2em;
13 | }
14 |
15 | .sourceCode {
16 | overflow: visible;
17 | }
18 |
19 | code.sourceCode>span {
20 | color: inherit;
21 | text-decoration: inherit;
22 | }
23 |
24 | div.sourceCode {
25 | margin: 1em 0;
26 | padding: 1em;
27 | border: #204a87 2px solid;
28 | border-radius: 1em;
29 | }
30 |
31 | pre.sourceCode {
32 | margin: 0;
33 | }
34 |
35 | @media screen {
36 | div.sourceCode {
37 | overflow: auto;
38 | }
39 | }
40 |
41 | @media print {
42 | pre>code.sourceCode {
43 | white-space: pre-wrap;
44 | }
45 |
46 | pre>code.sourceCode>span {
47 | text-indent: -5em;
48 | padding-left: 5em;
49 | }
50 | }
51 |
52 | pre.numberSource code {
53 | counter-reset: source-line 0;
54 | }
55 |
56 | pre.numberSource code>span {
57 | position: relative;
58 | left: -4em;
59 | counter-increment: source-line;
60 | }
61 |
62 | pre.numberSource code>span>a:first-child::before {
63 | content: counter(source-line);
64 | position: relative;
65 | left: -1em;
66 | text-align: right;
67 | vertical-align: baseline;
68 | border: none;
69 | display: inline-block;
70 | -webkit-touch-callout: none;
71 | -webkit-user-select: none;
72 | -khtml-user-select: none;
73 | -moz-user-select: none;
74 | -ms-user-select: none;
75 | user-select: none;
76 | padding: 0 4px;
77 | width: 4em;
78 | color: #aaaaaa;
79 | }
80 |
81 | pre.numberSource {
82 | margin-left: 3em;
83 | border-left: 1px solid #aaaaaa;
84 | padding-left: 4px;
85 | }
86 |
87 | div.sourceCode {
88 | background-color: transparent;
89 | }
90 |
91 | @media screen {
92 | pre>code.sourceCode>span>a:first-child::before {
93 | text-decoration: underline;
94 | }
95 | }
96 |
97 | code span.al {
98 | color: #ef2929;
99 | }
100 |
101 | /* Alert */
102 | code span.an {
103 | color: #8f5902;
104 | font-weight: bold;
105 | font-style: italic;
106 | }
107 |
108 | /* Annotation */
109 | code span.at {
110 | color: #204a87;
111 | }
112 |
113 | /* Attribute */
114 | code span.bn {
115 | color: #0000cf;
116 | }
117 |
118 | /* BaseN */
119 | code span.cf {
120 | color: #204a87;
121 | font-weight: bold;
122 | }
123 |
124 | /* ControlFlow */
125 | code span.ch {
126 | color: #4e9a06;
127 | }
128 |
129 | /* Char */
130 | code span.cn {
131 | color: #8f5902;
132 | }
133 |
134 | /* Constant */
135 | code span.co {
136 | color: #8f5902;
137 | font-style: italic;
138 | }
139 |
140 | /* Comment */
141 | code span.cv {
142 | color: #8f5902;
143 | font-weight: bold;
144 | font-style: italic;
145 | }
146 |
147 | /* CommentVar */
148 | code span.do {
149 | color: #8f5902;
150 | font-weight: bold;
151 | font-style: italic;
152 | }
153 |
154 | /* Documentation */
155 | code span.dt {
156 | color: #204a87;
157 | }
158 |
159 | /* DataType */
160 | code span.dv {
161 | color: #0000cf;
162 | }
163 |
164 | /* DecVal */
165 | code span.er {
166 | color: #a40000;
167 | font-weight: bold;
168 | }
169 |
170 | /* Error */
171 | code span.ex {}
172 |
173 | /* Extension */
174 | code span.fl {
175 | color: #0000cf;
176 | }
177 |
178 | /* Float */
179 | code span.fu {
180 | color: #204a87;
181 | font-weight: bold;
182 | }
183 |
184 | /* Function */
185 | code span.im {}
186 |
187 | /* Import */
188 | code span.in {
189 | color: #8f5902;
190 | font-weight: bold;
191 | font-style: italic;
192 | }
193 |
194 | /* Information */
195 | code span.kw {
196 | color: #204a87;
197 | font-weight: bold;
198 | }
199 |
200 | /* Keyword */
201 | code span.op {
202 | color: #ce5c00;
203 | font-weight: bold;
204 | }
205 |
206 | /* Operator */
207 | code span.ot {
208 | color: #8f5902;
209 | }
210 |
211 | /* Other */
212 | code span.pp {
213 | color: #8f5902;
214 | font-style: italic;
215 | }
216 |
217 | /* Preprocessor */
218 | code span.sc {
219 | color: #ce5c00;
220 | font-weight: bold;
221 | }
222 |
223 | /* SpecialChar */
224 | code span.ss {
225 | color: #4e9a06;
226 | }
227 |
228 | /* SpecialString */
229 | code span.st {
230 | color: #4e9a06;
231 | }
232 |
233 | /* String */
234 | code span.va {
235 | color: #000000;
236 | }
237 |
238 | /* Variable */
239 | code span.vs {
240 | color: #4e9a06;
241 | }
242 |
243 | /* VerbatimString */
244 | code span.wa {
245 | color: #8f5902;
246 | font-weight: bold;
247 | font-style: italic;
248 | }
249 |
250 | /* Warning */
--------------------------------------------------------------------------------
/lib/src/Okapi/Response.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE AllowAmbiguousTypes #-}
2 | {-# LANGUAGE ApplicativeDo #-}
3 | {-# LANGUAGE BlockArguments #-}
4 | {-# LANGUAGE DataKinds #-}
5 | {-# LANGUAGE DeriveGeneric #-}
6 | {-# LANGUAGE FlexibleContexts #-}
7 | {-# LANGUAGE FlexibleInstances #-}
8 | {-# LANGUAGE FunctionalDependencies #-}
9 | {-# LANGUAGE GADTs #-}
10 | {-# LANGUAGE ImportQualifiedPost #-}
11 | {-# LANGUAGE LambdaCase #-}
12 | {-# LANGUAGE MultiParamTypeClasses #-}
13 | {-# LANGUAGE OverloadedStrings #-}
14 | {-# LANGUAGE PolyKinds #-}
15 | {-# LANGUAGE QualifiedDo #-}
16 | {-# LANGUAGE RankNTypes #-}
17 | {-# LANGUAGE RecordWildCards #-}
18 | {-# LANGUAGE ScopedTypeVariables #-}
19 | {-# LANGUAGE StandaloneKindSignatures #-}
20 | {-# LANGUAGE TypeApplications #-}
21 | {-# LANGUAGE TypeFamilies #-}
22 | {-# LANGUAGE TypeOperators #-}
23 | {-# LANGUAGE UndecidableInstances #-}
24 |
25 | module Okapi.Response where
26 |
27 | import Control.Natural qualified as Natural
28 | import Data.Aeson qualified as Aeson
29 | import Data.Binary.Builder qualified as Builder
30 | import Data.ByteString qualified as BS
31 | import Data.ByteString.Char8 qualified as Char8
32 | import Data.ByteString.Lazy qualified as LBS
33 | import Data.ByteString.Lazy.Char8 qualified as LBSChar8
34 | import Data.CaseInsensitive qualified as CI
35 | import Data.Functor.Identity qualified as Identity
36 | import Data.Kind
37 | import Data.List qualified as List
38 | import Data.List.NonEmpty qualified as NonEmpty
39 | import Data.Text qualified as Text
40 | import Data.Text.Lazy qualified as LText
41 | import Data.Text.Lazy.Encoding qualified as Text
42 | import Data.Tree qualified as Tree
43 | import Data.Type.Equality qualified as Equality
44 | import Data.Typeable qualified as Typeable
45 | import Data.Vault.Lazy qualified as Vault
46 | import GHC.Exts qualified as Exts
47 | import GHC.Generics qualified as Generics
48 | import GHC.Natural qualified as Natural
49 | import GHC.TypeLits qualified as TypeLits
50 | import GHC.TypeNats qualified as Nat
51 | import Network.HTTP.Types qualified as HTTP
52 | import Network.Wai qualified as Wai
53 | import Okapi.Headers qualified as Headers
54 | import Okapi.Route qualified as Route
55 |
56 | import Web.HttpApiData qualified as Web
57 |
58 | data Headers (headerKeys :: [Exts.Symbol]) where
59 | NoHeaders :: Headers '[]
60 | InsertHeader ::
61 | forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]).
62 | (TypeLits.KnownSymbol headerKey, Web.ToHttpApiData headerValue) =>
63 | headerValue ->
64 | Headers headerKeys ->
65 | Headers (headerKey : headerKeys)
66 |
67 | noHeaders :: Headers '[]
68 | noHeaders = NoHeaders
69 |
70 | insertHeader ::
71 | forall (headerKey :: Exts.Symbol) headerValue (headerKeys :: [Exts.Symbol]).
72 | (TypeLits.KnownSymbol headerKey, Web.ToHttpApiData headerValue) =>
73 | headerValue ->
74 | Headers headerKeys ->
75 | Headers (headerKey : headerKeys)
76 | insertHeader = InsertHeader
77 |
78 | data HeaderKey (k :: Exts.Symbol) = HeaderKey
79 |
80 | -- | Membership test a type class (predicate)
81 | class IsMember (headerKey :: Exts.Symbol) (headerKeys :: [Exts.Symbol]) where
82 | -- | Value-level lookup of elements from a map, via type class predicate
83 | lookupHeader :: HeaderKey headerKey -> Headers headerKeys -> BS.ByteString
84 |
85 | instance {-# OVERLAPS #-} IsMember headerKey (headerKey ': rest) where
86 | lookupHeader _ (InsertHeader v _) = Web.toHeader v
87 |
88 | instance {-# OVERLAPPABLE #-} (IsMember headerKey headerKeys) => IsMember headerKey (otherHeaderKey ': headerKeys) where
89 | lookupHeader k (InsertHeader _ tail) = lookupHeader k tail
90 |
91 | class WaiResponseHeaders (headerKeys :: [Exts.Symbol]) where
92 | toWaiResponseHeaders :: Headers headerKeys -> HTTP.ResponseHeaders
93 |
94 | instance {-# OVERLAPS #-} WaiResponseHeaders '[] where
95 | toWaiResponseHeaders _ = []
96 |
97 | instance {-# OVERLAPPABLE #-} (WaiResponseHeaders headerKeys) => WaiResponseHeaders (headerKey ': headerKeys) where
98 | toWaiResponseHeaders (InsertHeader v tail) = [(CI.mk . Char8.pack $ TypeLits.symbolVal @headerKey Typeable.Proxy, Web.toHeader v)]
99 |
100 | data Body
101 | = BodyStream Wai.StreamingBody
102 | | BodyBuilder Builder.Builder
103 | | BodyBytes LBS.ByteString
104 | | BodyFile FilePath (Maybe Wai.FilePart)
105 |
106 | class ContentType a where
107 | contentTypeName :: BS.ByteString
108 | contentTypeBody :: a -> Body
109 |
110 | instance ContentType Text.Text where
111 | contentTypeName = "text/plain"
112 | contentTypeBody = BodyBytes . Text.encodeUtf8 . LText.fromStrict
113 |
114 | instance ContentType Aeson.Value where
115 | contentTypeName = "application/json"
116 | contentTypeBody = BodyBytes . Aeson.encode
117 |
118 | class (ContentType a) => ToContentType a b where
119 | toContentType :: b -> a
120 |
121 | instance ToContentType Text.Text Text.Text where
122 | toContentType = id
123 |
124 | instance ToContentType Text.Text Int where
125 | toContentType = Text.pack . show
126 |
127 | instance (Aeson.ToJSON a) => ToContentType Aeson.Value a where
128 | toContentType = Aeson.toJSON
129 |
130 | data Response where
131 | Response ::
132 | forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
133 | (ContentType contentType, ToContentType contentType resultType, Typeable.Typeable headerKeys, Typeable.Typeable resultType) =>
134 | Response
135 |
136 | natToStatus :: Nat.Nat -> HTTP.Status
137 | natToStatus n = toEnum $ fromEnum n
138 |
139 | makeResponder ::
140 | forall (status :: Natural.Natural) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type).
141 | (Nat.KnownNat status, WaiResponseHeaders headerKeys, ContentType contentType, ToContentType contentType resultType, Typeable.Typeable headerKeys, Typeable.Typeable resultType) =>
142 | (Headers headerKeys -> resultType -> Wai.Response)
143 | makeResponder headerMap result =
144 | let status = natToStatus $ Nat.natVal @status Typeable.Proxy
145 | contentType = toContentType @contentType @resultType result
146 | bodyType = contentTypeBody @contentType contentType
147 | name = contentTypeName @contentType
148 | headers = ("Content-Type", name) : toWaiResponseHeaders headerMap
149 | in case bodyType of
150 | BodyBytes bytes -> Wai.responseLBS status headers bytes
151 | BodyBuilder builder -> Wai.responseBuilder status headers builder
152 | BodyStream stream -> Wai.responseStream status headers stream
153 | BodyFile path part -> Wai.responseFile status headers path part
154 |
--------------------------------------------------------------------------------
/lib/src/Okapi.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE AllowAmbiguousTypes #-}
2 | {-# LANGUAGE ApplicativeDo #-}
3 | {-# LANGUAGE BlockArguments #-}
4 | {-# LANGUAGE DataKinds #-}
5 | {-# LANGUAGE FlexibleContexts #-}
6 | {-# LANGUAGE FlexibleInstances #-}
7 | {-# LANGUAGE GADTs #-}
8 | {-# LANGUAGE ImportQualifiedPost #-}
9 | {-# LANGUAGE LambdaCase #-}
10 | {-# LANGUAGE MultiParamTypeClasses #-}
11 | {-# LANGUAGE OverloadedStrings #-}
12 | {-# LANGUAGE PolyKinds #-}
13 | {-# LANGUAGE QualifiedDo #-}
14 | {-# LANGUAGE RankNTypes #-}
15 | {-# LANGUAGE RecordWildCards #-}
16 | {-# LANGUAGE ScopedTypeVariables #-}
17 | {-# LANGUAGE TypeApplications #-}
18 | {-# LANGUAGE TypeFamilies #-}
19 | {-# LANGUAGE TypeOperators #-}
20 |
21 | module Okapi where
22 |
23 | import Control.Natural qualified as Natural
24 | import Data.ByteString.Lazy qualified as LBS
25 | import Data.ByteString.Lazy.Char8 qualified as LBSChar8
26 | import Data.Functor.Identity qualified as Identity
27 | import Data.List qualified as List
28 | import Data.List.NonEmpty qualified as NonEmpty
29 | import Data.Text qualified as Text
30 | import Data.Tree qualified as Tree
31 | import Data.Typeable qualified as Typeable
32 | import Data.Vault.Lazy qualified as Vault
33 | import Network.HTTP.Types qualified as HTTP
34 | import Network.Wai qualified as Wai
35 | import Network.Wai.Handler.Warp qualified as Warp
36 | import Network.Wai.Middleware.RequestLogger qualified as Wai
37 | import Okapi.App
38 | import Okapi.App qualified as App
39 | import Okapi.Headers qualified as Headers
40 | import Okapi.Route qualified as Route
41 |
42 | import Text.Pretty.Simple qualified as Pretty
43 | import Web.HttpApiData qualified as Web
44 |
45 | {-
46 | test1 :: IO ()
47 | test1 = do
48 | apiTreeRep <- forest testAPI
49 | putStrLn $ Tree.drawTree apiTreeRep
50 | where
51 | -- Warp.run 1234 $ (build testAPI id) backupWaiApp
52 |
53 | backupWaiApp = \req resp -> do
54 | resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
55 | testAPI :: [App]
56 | testAPI =
57 | [ lit
58 | "" -- Won't be matched because you can't request http://localhost:1234/
59 | [ get_ id \req -> do
60 | return $ Wai.responseLBS HTTP.status200 [] "The trailing slash"
61 | ],
62 | lit
63 | "hello"
64 | [ get_ id \req -> do
65 | return $ Wai.responseLBS HTTP.status200 [] "world",
66 | lit
67 | ""
68 | [ get_ id \req -> do
69 | return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
70 | ],
71 | lit
72 | "world"
73 | [ get_ id \req -> do
74 | return $ Wai.responseLBS HTTP.status200 [] "!"
75 | ]
76 | ],
77 | get_ id \req -> do
78 | return $ Wai.responseLBS HTTP.status200 [] "You made a GET request to :ROOT:"
79 | ]
80 |
81 | test2 :: IO ()
82 | test2 = do
83 | apiTreeRep <- forest testAPI
84 | putStrLn $ Tree.drawTree apiTreeRep
85 | where
86 | -- Warp.run 1234 $ (build testAPI id) backupWaiApp
87 |
88 | backupWaiApp = \req resp -> do
89 | resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
90 | testAPI :: [App]
91 | testAPI =
92 | lit
93 | "" -- Won't be matched because you can't request http://localhost:1234/
94 | [ get_ id \req -> do
95 | return $ Wai.responseLBS HTTP.status200 [] "The trailing slash"
96 | ]
97 | : lit
98 | "hello"
99 | [ get_ id \req -> do
100 | return $ Wai.responseLBS HTTP.status200 [] "world",
101 | lit
102 | ""
103 | [ get_ id \req -> do
104 | return $ Wai.responseLBS HTTP.status200 [] "Trailing slash after \"hello\""
105 | ],
106 | lit
107 | "world"
108 | [ get_ id \req -> do
109 | return $ Wai.responseLBS HTTP.status200 [] "!"
110 | ]
111 | ]
112 | : ( get_ id \req -> do
113 | return $ Wai.responseLBS HTTP.status200 [] "You made a GET request to :ROOT:"
114 | )
115 | : []
116 |
117 | test3 :: IO ()
118 | test3 = do
119 | apiTreeRep <- forest testAPI
120 | putStrLn $ Tree.drawTree apiTreeRep
121 | where
122 | -- Warp.run 1234 $ (build testAPI id) backupWaiApp
123 |
124 | backupWaiApp = \_ resp -> do
125 | resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
126 | testAPI :: [App]
127 | testAPI =
128 | [ lit
129 | "numbers"
130 | [ lit
131 | "add"
132 | [ param @Int \xS ->
133 | [ param @Int \yS ->
134 | [ getIO_ \req -> do
135 | let magic = Secret.tell req
136 | x = magic xS
137 | y = magic yS
138 | return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x + y)
139 | ]
140 | ]
141 | ],
142 | getIO_ \req -> do
143 | return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
144 | ]
145 | ]
146 |
147 | data Op = Add | Sub | Mul
148 |
149 | instance Web.FromHttpApiData Op where
150 | parseUrlPiece "add" = Right Add
151 | parseUrlPiece "sub" = Right Sub
152 | parseUrlPiece "mul" = Right Mul
153 | parseUrlPiece _ = Left undefined
154 |
155 | test4 :: IO ()
156 | test4 = do
157 | apiTreeRep <- forest testAPI
158 | putStrLn $ Tree.drawTree apiTreeRep
159 | where
160 | -- Warp.run 1234 $ Wai.logStdoutDev $ build testAPI id backupWaiApp
161 |
162 | backupWaiApp = \_ resp -> do
163 | resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
164 | testAPI :: [App]
165 | testAPI =
166 | [ lit
167 | "numbers"
168 | [ param @Op \opS ->
169 | [ param @Int \xS ->
170 | [ param @Int \yS ->
171 | [ getIO_ \req -> do
172 | let x = Secret.tell req xS
173 | y = Secret.tell req yS
174 | answer = case Secret.tell req opS of
175 | Add -> x + y
176 | Sub -> x - y
177 | Mul -> x * y
178 | return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show answer
179 | ]
180 | ],
181 | getIO_ \req -> do
182 | return $ Wai.responseLBS HTTP.status200 [] $ case Secret.tell req opS of
183 | Add -> "Add two numbers."
184 | Sub -> "Subtract one number from another."
185 | Mul -> "Multiply two numbers."
186 | ],
187 | getIO_ \req -> do
188 | return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
189 | ]
190 | ]
191 |
192 | instance Web.ToHttpApiData Op where
193 | toUrlPiece Add = "add"
194 | toUrlPiece Sub = "sub"
195 | toUrlPiece Mul = "mul"
196 |
197 | test5 :: IO ()
198 | test5 = do
199 | apiTreeRep <- forest testAPI
200 | -- apiEndpoints <- endpoints testAPI
201 | putStrLn $ Tree.drawTree apiTreeRep
202 | where
203 | -- Pretty.pPrint $ map curl $ List.reverse apiEndpoints
204 |
205 | -- Warp.run 1234 $ build testAPI id backupWaiApp
206 |
207 | backupWaiApp = \_ resp -> do
208 | resp $ Wai.responseLBS HTTP.status404 [] "The test app failed..."
209 | testAPI :: [App]
210 | testAPI =
211 | [ lit "numbers" $
212 | [ getIO_ \req -> do
213 | return $ Wai.responseLBS HTTP.status200 [] "Use /add, /sub, or /mul"
214 | ]
215 | ++ map opAPI [Add, Sub, Mul]
216 | ]
217 |
218 | opAPI :: Op -> App
219 | opAPI op =
220 | match
221 | op
222 | [ getIO_ \req -> do
223 | return $ Wai.responseLBS HTTP.status200 [] $ case op of
224 | Add -> "Add two numbers."
225 | Sub -> "Subtract one number from another."
226 | Mul -> "Multiply two numbers.",
227 | param @Int \xS ->
228 | [ param @Int \yS ->
229 | [ getIO_ \req -> do
230 | let x = Secret.tell req xS
231 | y = Secret.tell req yS
232 | answer = case op of
233 | Add -> x + y
234 | Sub -> x - y
235 | Mul -> x * y
236 | return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show answer
237 | ]
238 | ]
239 | ++ case op of
240 | Mul ->
241 | [ getIO_ \req -> do
242 | let x = Secret.tell req xS
243 | return $ Wai.responseLBS HTTP.status200 [] $ LBSChar8.pack $ show (x * x)
244 | ]
245 | _ -> []
246 | ]
247 | -}
248 | -- test6 :: IO ()
249 | -- test6 = do
250 | -- apiTreeRep <- forest testAPI
251 | -- putStrLn $ Tree.drawTree apiTreeRep
252 | -- where
253 | -- backupWaiApp = \req resp -> do
254 | -- resp $ Wai.responseLBS HTTP.status200 [] "The test app failed..."
255 | -- testAPI :: [App]
256 | -- testAPI =
257 | -- [ endpoint HTTP.GET (do Route.lit "user";) id \_ req -> do
258 | -- undefined
259 | -- , endpoint HTTP.POST (do Route.lit "user"; id' <- Route.param @Int; return id') id \userIDS req -> do
260 | -- let userID = Secret.tell req userIDS
261 | -- undefined
262 | -- ]
263 |
--------------------------------------------------------------------------------
/lib/release.md:
--------------------------------------------------------------------------------
1 | ## Introduction
2 |
3 | Okapi is a microframework for web development in Haskell based on monadic parsing.
4 | The inspiration for Okapi originally came from looking at web frameworks in other language ecosystems such as Python’s Flask,
5 | Nim’s Jester, OCaml’s Dream, and F#’s Giraffe, which the name of this Haskell framework is related to.
6 | I noticed that many Haskell web frameworks tend to require a lot of boilerplate code, and/or make use of a lot of advanced type level language
7 | features that make it hard to understand the internals of the framework. The goal of Okapi is to create a Haskell web framework
8 | with an ergonomic developer experience that is idiomatic to the host language.
9 |
10 | ## Parsers
11 |
12 |
13 | In Haskell, a simple `String` parser can be modeled as a function with the type `String -> (Either ParserError a, String)`.
14 | This function takes values of type `String` and returns either a `ParserError` (if it fails) or a value of some type `a` (if it succeeds), along with a new `String`
15 | that's missing the characters that were consumed by the parsing function. We could use the function like so:
16 |
17 | ```haskell
18 | ```
19 |
20 | This is great, but issues start to arise when we try to compose parsers with other parsers. For example, let's say we wanted to parse blah blah:
21 |
22 | ```haskell
23 | ```
24 |
25 | To avoid the explicit passing of state from one parser to the next, we can use monads. You may have already noticed that the type of our parser can be simplified with the `State String` monad.
26 | We can transform our function of type `String -> (Either ParseError a, String)` to a value of type `State String (Either ParserError a)`. A value of type `State String (Either ParserError a)`
27 | represents a value of type `Either ParserError a` that was computed in a stateful context, where the state is of type `String`. Now that our parser is defined as a monad we can use `do` notation
28 | , and it becomes easier to compose our parsers with other parsers because we don't have to manually pass the state from a previous parser to the next one.
29 | Let's try the parser composition we tried above with our new parser definition:
30 |
31 | ```haskell
32 | ```
33 |
34 |
36 |
37 | As you can see our parsers compose a lot better, but we still have to explicitly handle the result of the parsers because they may return a `ParserError`.
38 | Functions that return values of the type `Either ParserError a` can be modelled using the `Except ParserError` monad. A value of the type `Except ParserError a`
39 | represents a value of type `a` that is computed in a context that may not succeed, but instead throw an error value of type `ParserError`. In our case we want
40 | our parser's computations to happen in a context in which there is state of type `String`, and the possibilty of throwing an error value of type `ParserError`.
41 | To get both of these useful abilities, let's combine the `Except ParserError` monad with our `State String` monad using monad transformers. Our simplified parser
42 | now has the type `ExceptT ParserError (State String a)`, where `ExceptT` is a monad transformer that gives our base `State String` monad the ability to throw error
43 | values of type `ParserError` upon failure. To make the code examples easier on our eyes, let's make a type synonym defined as `type Parser a = ExceptT ParserError (State String a)`.
44 | Now, any value anottated with the type `Parser a` represents a value of some type `a` that is computed in a context that has access to state of type `String` AND may throw error
45 | values of type `ParserError` upon failing. Let's redefine the example we defined above:
46 |
47 | ```haskell
48 | ```
49 |
50 | Great.
51 |
52 | ## HTTP Request Parsers
53 |
54 | Now, let's redefine `type Parser a = ExceptT ParserError (State String a)` as `type Parser a = ExceptT HTTPError (State HTTPRequest a)`. This is an HTTP Request Parser. Instead of parsing happening in a context where the computation has access to state of type `String` and can throw errors of type `ParserError`, it happens in a context where the computation has access to state of type `HTTPRequest` and can throw errors of type `HTTPError`. Just like the string parser above had a concept of "consuming" parts of a `String`, the HTTP request parser "consumes" values of the type `HTTPRequest`. By consume we mean .... If you break values of type `String` into its smallest consituents, you get values of type `Char`. A `String` value is a list of `Char` values. What are the smallest constituents of a `HTTPRequest` value? The data type `HTTPRequest` is defined as follows:
55 |
56 | ```haskell
57 | data HTTPRequest = HTTPRequest
58 | { method :: Method
59 | , path :: [Text]
60 | , query :: Query
61 | , body :: ByteString
62 | , headers :: Headers
63 | }
64 | ```
65 |
66 |
68 | Our HTTP request parser consumes different parts of the HTTP request like the `method` and `query`. Once a piece of the HTTP request is parsed, it is removed from the request before it is implicitly passed to the next parser.
69 |
70 | There are 2 types of parsers:
71 |
72 | 1. Data parsers
73 | 2. Checker parsers
74 |
75 | There are 5 types of parsers for each of the 5 parts of a HTTP request.
76 |
77 | 1. Method Parsers
78 |
79 | ```haskell
80 | method :: MonadOkapi m => m Method
81 |
82 | matchMethod :: MonadOkapi m => Method -> m ()
83 |
84 | get :: MonadOkapi m => m ()
85 | get = matchMethod "GET"
86 | ```
87 |
88 | 2. Path Parsers
89 |
90 | ```haskell
91 | path :: MonadOkapi m => m Path -- Parses entire remaining path
92 | path = many seg
93 |
94 | seg :: MonadOkapi m => m Text
95 |
96 | matchPath :: MonadOkapi m => Path -> m ()
97 | matchPath desiredPath = mapM_ matchSeg desiredPath
98 |
99 | matchSeg :: MonadOkapi m => Text -> m ()
100 |
101 | pathParam :: MonadOkapi m => FromHttpApiData a => m a
102 |
103 | pathEnd :: MonadOkapi m => m ()
104 | ```
105 |
106 | 4. Query Parsers
107 |
108 | ```haskell
109 | query :: MonadOkapi m => m Query -- parses entire query
110 |
111 | queryParam :: MonadOkapi m => FromHttpApiData a => Text -> m a
112 |
113 | queryFlag :: MonadOkapi m => Text -> m ()
114 |
115 | queryParamRaw :: Text -> m Text
116 | ```
117 |
118 | 6. Body Parsers
119 |
120 | ```haskell
121 | body :: MonadOkapi m => m Body
122 |
123 | bodyJSON :: MonadOkapi m, FromJSON a => m a
124 |
125 | bodyURLEncoded :: FromForm a, MonadOkapi m => m a
126 |
127 | bodyMultipart :: FromForm a, MonadOkapi m => m (a, [File])
128 | ```
129 |
130 | 8. Headers Parsers
131 |
132 | ```haskell
133 | headers :: MonadOkapi m => m Headers
134 |
135 | header :: MonadOkapi m => HeaderName -> m Header
136 |
137 | cookie :: MonadOkapi m => m Cookie
138 |
139 | crumb :: MonadOkapi m => Text -> m Crumb
140 | ```
141 |
142 | We can use these to create increasingly complex parsers. For example, let's say we wanted to implement a HTTP parser that matches the request `GET /blog`. That would look like this:
143 |
144 | ```haskell
145 | blogRoute :: Parser ()
146 | blogRoute = do
147 | get -- Make sure that the request is a GET request
148 | matchSeg "blog" -- Match against the path segment /blog
149 | pathEnd -- Make sure that there are no more path segments remaining in the request
150 | ```
151 |
152 | Just like earlier, with our monadic string parser, we can sequence HTTP request parsers using `do` notation. This request parser isn't really useful though because it doesn't return anything. Let's make it return a response:
153 |
154 | ```haskell
155 | blogRoute :: Parser HTTPResponse
156 | blogRoute = do
157 | get
158 | matchSeg "blog"
159 | pathEnd
160 | return ok
161 | ```
162 |
163 | Now if we run our parser, it will return a `200 OK` response if we send a `GET` request to the `/blog` endpoint. On top of being able to sequence parsers with `do` notation thanks to `Parser` being an instance of the `Monad` typeclass, we can also build parsers that "choice" between multiple subparsers. This is possible because the `Parser` type is also an instance of the `Alternative` typeclass, which provides the `<|>` operator.
164 |
165 | Explain `<|>` then explain we can also parser combinators like `many`, `some`, `optional`, `option`, `takeWhile`, etc.
166 |
167 | Then explain the two types of errors and how to throw and catch them.
168 |
169 | Then explain returning responses and executing a parser.
170 |
171 | Explaining type safe URLs with patterns:
172 |
173 | ## Patterns
174 |
175 | Okapi uses bi-directional patterns to have typesafe urls. So you would have something like:
176 |
177 | ```haskell
178 | -- Matches routes of the form /blog/99
179 | pattern BlogRoute :: Int -> Path
180 | pattern BlogRoute uuid <- ["blog", PathParam uuid]
181 | where
182 | BlogRoute uuid = ["blog", PathParam uuid]
183 | ```
184 |
185 | or just
186 |
187 | ```haskell
188 | -- Bidriectional Implicit
189 | pattern BlogRoute :: Int -> Path
190 | pattern BlogRoute uuid = ["blog", PathParam uuid]
191 |
192 | pattern BlogCategoryRoute :: Text -> Path
193 | pattern BlogCategoryRoute category = ["blog", PathParam category]
194 | ```
195 |
196 | uses these bidrectional patterns with the `route` parser, like so:
197 |
198 | ```haskell
199 | route :: MonadOkapi m => (Path -> m Response) -> m Response
200 | route matcher = do
201 | path <- parsePath
202 | matcher path
203 |
204 | myAPI :: MonadOkapi m => m Response
205 | myAPI = route $ \case
206 | BlogRoute uuid -> do
207 | get
208 | return ok
209 | BlogRouteCategory category -> do
210 | get
211 | mbOrderBy <- optional $ queryParam @Order "order"
212 | case mbOrderBy of
213 | Nothing -> do
214 | ...
215 | return ok
216 | Just orderBy -> do
217 | ...
218 | return ok
219 | _ -> next
220 | ```
221 |
222 | Since both routes are `GET` requests, let's factor out the `get` parser:
223 |
224 | ```haskell
225 | myAPI :: MonadOkapi m => m Response
226 | myAPI = do
227 | get
228 | route $ \case
229 | BlogRoute uuid -> return ok
230 | BlogRouteCategory category -> do
231 | mbOrderBy <- optional $ queryParam @Order "order"
232 | case mbOrderBy of
233 | Nothing -> do
234 | ...
235 | return ok
236 | Just orderBy -> do
237 | ...
238 | return ok
239 | _ -> next
240 | ```
241 |
242 | ## URLs
243 |
244 | There are two types of URLs that you can generate with Okapi:
245 |
246 | 1. Relative URLs
247 | 2. Absolute URLs
248 |
249 | ```haskell
250 | data URL = URL { unURL :: Text }
251 | data RelURL = RelURL Path Query
252 | data AbsURL = AbsURL Scheme Host (Maybe Port) RelURL
253 |
254 | class ToURL a where
255 | render :: a -> URL
256 |
257 | instance ToURL Path where
258 |
259 | instance ToURL Query where
260 |
261 | instance ToURL RelURL where
262 | render (RelURL p q) = render p <> render q
263 |
264 | instance ToURL AbsURL where
265 |
266 | instance ToURL Request where
267 |
268 | blogRouteCategoryURL = render $ BlogRouteCategory "fiction"
269 |
270 | class ToURL a => Matchable a where
271 | match :: (a -> m Response) -> m Response
272 |
273 | route :: (Path -> m Response) -> m Response
274 | routeWithQuery :: (RelURL -> m Response) -> m Response
275 | routeVirtual :: (AbsURL -> m Response) -> m Response
276 | ```
277 |
--------------------------------------------------------------------------------
/lib/NewDesign.md:
--------------------------------------------------------------------------------
1 | # Build A Web Framework in Haskell From Scratch
2 |
3 | ## Haskell for Backend Web Development
4 |
5 | ## What is WAI?
6 |
7 | ## The Simplest Possible Server
8 |
9 | ```haskell
10 | server :: Request -> Response
11 | ```
12 |
13 | ## Interacting With The Real World
14 |
15 | ```haskell
16 | server :: Monad m => Request -> m Response
17 | ```
18 |
19 | ```haskell
20 | server :: Request -> Identity Response
21 | ```
22 |
23 | ## Making Our Server Modular
24 |
25 | ```haskell
26 | server :: Reader Request Response
27 | ```
28 |
29 | ## Separating Effects
30 |
31 | Once concern with the Okapi monad is that I can interleave random `IO` actions in the route parser. This means the programmer has to be careful of where `IO` actions are executed. Once an `IO` action is executed, it can't be undone. Even with backtracking. In practice, we want to keep our route parser, and handler (which might use `IO`) separate.
32 |
33 | 1. The Router - The one and only job of the router is to **extract and verify the existence of data in the request**.
34 | 2. The Handler - The one and only job of the handler is to **accept data provided by the router and generate a response in the desired context**.
35 |
36 | In this way, we achieve separation of concerns. What does this look like?
37 |
38 | ```haskell
39 | server
40 | :: Monad m
41 | => Router a -- Router
42 | -> (a -> m Response) -- Handler
43 | -> (m a -> IO a) -- Lifter
44 | -> Application -- Application
45 | server = undefined
46 | ```
47 |
48 | ```haskell
49 | data Router a = Router
50 | {
51 | }
52 |
53 | server
54 | :: Monad m
55 | => Router a -- Router
56 | -> (a -> m Response) -- Handler
57 | -> (m ~> IO) -- Lifter (Natural Transformation)
58 | -> Application -- Application
59 | server = undefined
60 |
61 | serverPure
62 | :: (Request -> a)
63 | -> (a -> Response)
64 | -> Application
65 | serverPure = undefined
66 |
67 | serverPure'
68 | :: (Request -> Response)
69 | -> Application
70 | serverPure' = undefined
71 | ```
72 |
73 | ### A Simpler Routing Interface
74 |
75 | ```haskell
76 | server
77 | :: (RouteData -> Route -> m Response)
78 | -> (m ~> IO)
79 | -> Application
80 | server f nt = ...
81 | ```
82 |
83 | ```haskell
84 | data Route = Route
85 | { method :: Method
86 | , path :: [Text]
87 | }
88 |
89 | pattern GetUser :: UserID -> Route
90 | pattern GetUser userID = Route GET ["users", userID]
91 |
92 | pattern PostUser :: UserID -> Route
93 | pattern PostUser userID = Route POST ["users", userID]
94 |
95 | server
96 | :: RouteData
97 | -> Route %1
98 | -> m Response
99 | server routeData = \case
100 | GetUser userID -> do
101 | ...
102 | PostUser userID -> do
103 | ...
104 | _ -> return notFoundResponse
105 | ```
106 |
107 | ```haskell
108 | -- Record of higher order functions
109 | data RouteData = RouteData
110 | { queryParam :: HttpApiData a => Text -> Result a
111 | , header :: HttpApiData a => Text -> Result a
112 | , body :: ...
113 | , file :: ...
114 | , formParam :: ...
115 | , ...
116 | }
117 |
118 | server
119 | :: RouteData
120 | -> Route %1
121 | -> m Response
122 | server routeData route = do
123 | let
124 | setup1 = do
125 | ...
126 | setup2 = ...
127 | setup3 <- ...
128 | case route of
129 | GetUser userID -> do
130 | ...
131 | PostUser userID -> do
132 | ...
133 | _ -> return notFoundResponse
134 | ```
135 |
136 | ### Alternate Syntax
137 |
138 | #### Fast API Like
139 |
140 | ```haskell
141 | getUsers :: Controller
142 | getUsers = [get|
143 | /users
144 | ?age:Int
145 | ?name:Text
146 | ?status:Status
147 | |] id handler
148 | where
149 | handler :: (Int, Text, Status) -> m Response
150 | handler = ...
151 |
152 | [post| /user/:UserID |] :: ...
153 |
154 | [put| /user/:UserID |]
155 | ```
156 |
157 | #### Controller Method
158 |
159 | ```haskell
160 | data Error = JSONError ... | ...
161 | data Result a = Cont a | Next
162 |
163 | data Extractor a = ...
164 |
165 | instance Applicative Extractor where
166 |
167 | extractUser :: Extractor User
168 | extractUser = do
169 | methodIs GET
170 | pathParamIs @Text "users" <|> pathParamIs "people"
171 | userID <- pathParam @UserID
172 | userQuery <- json @UserQuery
173 | pure GetUser{..}
174 |
175 | data Extractor a = Ok a | Fail
176 |
177 | data Result a = Respond a | Next
178 |
179 | type Handler m a = Extractor a -> m (Result Response)
180 |
181 | controller
182 | :: (m ~> IO)
183 | -> Extractor a
184 | -> Handler m a
185 | -> Controller
186 | controller transformer router handler = ...
187 |
188 | combineController
189 | :: Controller
190 | -> Controller
191 | -> Controller
192 | combineController c1 c2 = ...
193 | ```
194 |
195 | ```haskell
196 | data Controller = Controller
197 | {
198 | }
199 | ```
200 |
201 | ### Mixing Patterns with Extractors
202 |
203 | Use patterns for method and path. Use extractors for everything else.
204 |
205 | ```haskell
206 | router :: Route -> Extractor a
207 | router = \case
208 | (GET, ["index"]) -> do
209 | ..
210 | (GET, ["posts", PathParam postID]) -> do
211 | ..
212 | _ -> undefined
213 | ```
214 |
215 | Probably not ideal because the exact extractor value can depend on the path parameter. We can't guarantee the developer won't do this.
216 |
217 | ### Route as Data
218 |
219 | ```haskell
220 | myRoute :: Endpoint
221 | myRoute = Endpoint
222 | { method = GET
223 | , path =
224 | [ Static "people"
225 | , Param @PersonID "personID"
226 | ]
227 | , query =
228 | [ Param @Bool "profile"
229 | ]
230 | , headers =
231 | [ Param @Text "X-Some-Header"
232 | ]
233 | , body = JSON @PersonFilter
234 | }
235 | ```
236 |
237 | Combine with extractor DSL?
238 |
239 | ```haskell
240 | myRoute :: Endpoint pd qd hd bd
241 | myRoute = Endpoint
242 | { method = GET
243 | , path = do
244 | static "profile"
245 | pID <- param @ProfileID
246 | pure pID
247 | , query = do
248 | useProfile <- flag "profile"
249 | pure useProfile
250 | , headers = NoHeaders
251 | , body = json @PersonFilter
252 | }
253 |
254 | myRoute' :: Endpoint pd qd hd bd rd
255 | myRoute' = Endpoint
256 | { method = GET :| [PUT, POST]
257 | , path = do
258 | static "profile"
259 | pID <- param @ProfileID
260 | pure pID
261 | , query = do
262 | useProfile <- flag "profile"
263 | pure useProfile
264 | , headers = NoHeaders
265 | , body = do
266 | filter <- json @PersonFilter
267 | pure filter
268 | , responder = do
269 | sendOk <- ok
270 | sendNotFound <- notFound
271 | pure Send{..}
272 | }
273 |
274 | myRoute'' :: Endpoint pd qd hd bd rd
275 | myRoute'' = Endpoint
276 | GET
277 | static "index"
278 | NoQuery
279 | NoHeaders
280 | NoBody
281 | ok
282 |
283 | data Params pd qd hd bd rd = Params
284 | { path :: pd
285 | , query :: qd
286 | , headers :: hd
287 | , body :: bd
288 | , response :: rd %1
289 | -- TODO: Have two fields for response ~
290 | -- On Error and on Ok
291 | -- , responseError :: red %1
292 | }
293 |
294 | -- Use type level function to produce types for both
295 | -- Endpoint and Params.
296 |
297 | myHandler
298 | :: Monad m
299 | => (Params pd qd hd bd rd) %1
300 | -> m (Action Response)
301 | myHandler paramsResult = case paramsResult of
302 | Error err -> do
303 | -- | Do logging or whatever if error
304 | liftIO $ print err
305 | return Next
306 | Ok params -> do
307 | let
308 | profileID = path params
309 | isProfileView = query params
310 | personFilter = body params
311 |
312 | return $ params.response.respondOk responseValue
313 |
314 | makeController
315 | :: Monad m
316 | => (m ~> IO)
317 | -> Endpoint pd qd hd bd rd
318 | -> (Params pd qd hd bd rd -> m Response)
319 | -> Controller
320 | makeController lifter endpoint handler = ...
321 | ```
322 |
323 | The above seems to be the best design.
324 |
325 | ### Combining Controllers
326 |
327 | #### Non-Empty List
328 |
329 | ```haskell
330 | type Server = NonEmptyList Controller
331 | -- Use Map instead
332 |
333 | myServer = controller1 :| [controller2, controller3]
334 |
335 | genApplication
336 | :: ServerOptions
337 | {-| Control body max size
338 | , default response
339 | , IO error to response
340 | , etc.
341 | -}
342 | -> Server
343 | -> Application
344 |
345 | genJSClient :: Server -> FilePath -> IO ()
346 |
347 | genOpenAPISpec :: Server -> OpenAPISpec
348 | ```
349 |
350 | `genApplication` takes server options and a server definition.
351 |
352 |
353 |
354 | ## Megalith Web Framework
355 |
356 | ### File-based Routing
357 |
358 | Megalith supports file-based routing. Placing a `.ml` file in your project's `pages` directory will automatically generate a route to that page. `.ml` files can contain plain HTML. Here's an example `.ml` file called `index.ml`:
359 |
360 | ```html
361 |
362 |
363 | Welcome to my website.
364 |
365 |
366 | This website was built using the Megalith web framweork.
367 |
368 |
384 |
This is the $(category::Text) category.
385 |
386 | ```
387 |
388 | Maybe consider using `!` instead of `[]` for dynamic routes.
389 |
390 | Running the app and going to `localhost:3000/pages/products/watches` will render the page:
391 |
392 | ```html
393 |
394 |
This is the watches category.
395 |
396 | ```
397 |
398 | ### Template Syntax
399 |
400 | Pushup like approach:
401 |
402 | ```haskell
403 | myHTML :: HTML
404 | myHTML =
405 |
406 | ^forEach [1..10] \n ->
407 | - Number: ^n
408 |
409 | ```
410 |
411 | Or, a more traditional approach:
412 |
413 | ```haskell
414 | myHTML :: HTML
415 | myHTML =
416 |
419 | where
420 | list = forEach [1..10] \n -> Number: {n}
421 | ```
422 |
423 | Megalith includes a GHC plugin that introduces a literal syntax for HTML tags. Inspired by JSX and Phoenix Components.
424 |
425 | ### Components
426 |
427 | ```haskell
428 | type Component a = a -> HTML
429 |
430 | class Component a where
431 | render :: a -> HTML
432 | ```
433 |
434 | ### Routes
435 |
436 | ```haskell
437 | get
438 | :: Parser a
439 | -> (a -> m Response)
440 | -> ???
441 | ```
442 |
443 | ```haskell
444 | type Application m a = (Parser a, a -> m Response)
445 | ```
446 |
447 | ### Server Pages
448 |
449 | ```haskell
450 | -- pages/index.mli --> localhost:3000/index
451 |
452 |
453 |
Welcome to the Home Page!
454 |
455 | ```
456 |
457 | ```haskell
458 | -- pages/products/[category].mli
459 | import Data.Text
460 |
461 |
462 |
463 |
464 | ```
465 |
466 | ```haskell
467 | Plan.Plan
468 | { lifter = id,
469 | endpoint =
470 | Endpoint.Endpoint
471 | { method = GET,
472 | path = do
473 | Path.static "index"
474 | magicNumber <- Path.param @Int
475 | pure magicNumber,
476 | query = do
477 | x <- Query.param @Int "x"
478 | y <- Query.option 10 $ Query.param @Int "y"
479 | pure (x, y),
480 | headers = pure (),
481 | body = pure (),
482 | responder = do
483 | itsOk <- Responder.json
484 | @Int
485 | HTTP.status200
486 | do
487 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
488 | pure addSecretNumber
489 | pure itsOk
490 | },
491 | handler = \(Params.Params magicNumber (x, y) () () responder) -> do
492 | let newNumber = magicNumber + x * y
493 | print newNumber
494 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
495 | }
496 | ```
497 |
498 | ```haskell
499 | Plan.Plan
500 | { -- Identity function as the lifter.
501 | lifter = id,
502 |
503 | -- Define the endpoint for the web service.
504 | endpoint =
505 | Endpoint.Endpoint
506 | { -- HTTP GET method for this endpoint.
507 | method = GET,
508 |
509 | -- Path pattern for this endpoint.
510 | path = do
511 | -- Expect "index" as a static part of the path.
512 | Path.static "index"
513 |
514 | -- Capture an integer parameter from the path.
515 | magicNumber <- Path.param @Int
516 | pure magicNumber,
517 |
518 | -- Query parameters for this endpoint.
519 | query = do
520 | -- Capture an integer query parameter named "x".
521 | x <- Query.param @Int "x"
522 |
523 | -- Capture an optional integer query parameter named "y" with a default value of 10.
524 | y <- Query.option 10 $ Query.param @Int "y"
525 | pure (x, y),
526 |
527 | -- No specific headers expected for this endpoint.
528 | headers = pure (),
529 |
530 | -- No request body expected for this endpoint.
531 | body = pure (),
532 |
533 | -- Define the responder for this endpoint.
534 | responder = do
535 | -- Create a JSON responder with HTTP status 200 and an integer value.
536 | itsOk <- Responder.json @Int HTTP.status200
537 | do
538 | -- Check for the presence of an "X-SECRET" header with an integer value.
539 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
540 | pure addSecretNumber
541 |
542 | -- Return the configured responder.
543 | pure itsOk
544 | },
545 |
546 | -- Define the handler function for the web service.
547 | handler = \(Params.Params magicNumber (x, y) () () responder) -> do
548 | -- Calculate a new number based on the magicNumber, x, and y.
549 | let newNumber = magicNumber + x * y
550 |
551 | -- Print the new number to the console.
552 | print newNumber
553 |
554 | -- Return a response with the new number and an additional header based on the new number.
555 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
556 | }
557 |
558 | ```
559 |
560 |
561 | ```haskell
562 | Plan.Plan
563 | { lifter = id,
564 | endpoint = Endpoint.Endpoint
565 | GET
566 | do
567 | Path.static "index"
568 | magicNumber <- Path.param @Int
569 | pure magicNumber
570 | do
571 | x <- Query.param @Int "x"
572 | y <- Query.option 10 $ Query.param @Int "y"
573 | pure (x, y)
574 | pure ()
575 | pure ()
576 | do
577 | itsOk <- Responder.json @Int HTTP.status200
578 | do
579 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
580 | pure addSecretNumber
581 | pure itsOk
582 | handler = \(Params.Params magicNumber (x, y) () () responder) -> do
583 | let newNumber = magicNumber + x * y
584 | print newNumber
585 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
586 | }
587 | ```
588 |
589 | ```haskell
590 | Plan
591 | Endpoint
592 | Method.GET
593 | Path.do
594 | Path.static "index"
595 | magicNumber <- Path.param @Int
596 | Path.pure magicNumber
597 | Query.do
598 | x <- Query.param @Int "x"
599 | y <- Query.option 10 $ Query.param @Int "y"
600 | Query.pure (x, y)
601 | Headers.pure ()
602 | Body.pure ()
603 | Responder.do
604 | itsOk <- Responder.json @Int HTTP.status200
605 | AddHeader.do
606 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
607 | AddHeader.pure addSecretNumber
608 | Responder.pure itsOk
609 | \magicNumber (x, y) () () responder -> do
610 | let newNumber = magicNumber + x * y
611 | print newNumber
612 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
613 | id
614 | ```
615 |
616 | ```haskell
617 | Plan $$
618 | Endpoint $$
619 | Method.GET
620 | Path.do
621 | Path.static "index"
622 | magicNumber <- Path.param @Int
623 | Path.pure magicNumber
624 | Query.do
625 | x <- Query.param @Int "x"
626 | y <- Query.option 10 $ Query.param @Int "y"
627 | Query.pure (x, y)
628 | Headers.pure ()
629 | Body.pure ()
630 | Responder.do
631 | itsOk <- Responder.json @Int HTTP.status200
632 | AddHeader.do
633 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
634 | AddHeader.pure addSecretNumber
635 | Responder.pure itsOk
636 | \magicNumber (x, y) () () responder -> do
637 | let newNumber = magicNumber + x * y
638 | print newNumber
639 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
640 | id
641 | ```
642 |
643 | ```haskell
644 | Plan $$
645 | Endpoint $$
646 | GET
647 | do
648 | Path.static "index"
649 | magicNumber <- Path.param @Int
650 | pure magicNumber
651 | do
652 | x <- Query.param @Int "x"
653 | y <- Query.option 10 $ Query.param @Int "y"
654 | pure (x, y)
655 | do pure ()
656 | do pure ()
657 | do
658 | itsOk <- Responder.json @Int HTTP.status200 do
659 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
660 | AddHeader.pure addSecretNumber
661 | pure itsOk
662 | \magicNumber (x, y) () () responder -> do
663 | let newNumber = magicNumber + x * y
664 | print newNumber
665 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
666 | id
667 | ```
668 |
669 | ### Endpoint Patterns
670 |
671 | ```haskell
672 | data Request = Request StdMethod [Text] Query BS.ByteString RequestHeaders
673 | data Server m r = Server
674 | { responder :: Responder r
675 | , handler :: Request -> r -> m Response
676 | }
677 |
678 | pattern GetUsers :: Maybe Filter -> Request
679 | pattern GetUsers optFilter <- Request
680 | GET
681 | ["users"]
682 | (Query.eval filterQuery -> Ok filter)
683 | ""
684 | _
685 |
686 | pattern AddUser :: User -> Request
687 | pattern AddUser user <- Request
688 | POST
689 | ["users"]
690 | _
691 | (Body.eval (json @User) -> Ok user)
692 | _
693 |
694 | pattern GetUsersByID :: UserID -> MatcherInput
695 | pattern GetUsersByID userID <- Request
696 | GET
697 | (Path.eval pathParams -> Ok userID)
698 | _
699 | ""
700 | _
701 | where
702 | pathParams = do
703 | Path.static "users"
704 | userID <- Path.param @UserID "userID"
705 | pure userID
706 |
707 | myServer :: MyResponderType -> Request -> IO Response
708 | myServer res = \case
709 | GetUser -> do
710 | ...
711 | GetUserByID userID -> do
712 | ...
713 | AddUser user -> do
714 | ...
715 | _ -> do
716 | ...
717 |
718 | myServer = Server myResponder myServer
719 |
720 | spend :: a %1 -> a %m ????
721 | ```
722 |
--------------------------------------------------------------------------------
/lib/src/Okapi/App.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE AllowAmbiguousTypes #-}
2 | {-# LANGUAGE ApplicativeDo #-}
3 | {-# LANGUAGE BlockArguments #-}
4 | {-# LANGUAGE DataKinds #-}
5 | {-# LANGUAGE DeriveGeneric #-}
6 | {-# LANGUAGE FlexibleContexts #-}
7 | {-# LANGUAGE FlexibleInstances #-}
8 | {-# LANGUAGE FunctionalDependencies #-}
9 | {-# LANGUAGE GADTs #-}
10 | {-# LANGUAGE ImportQualifiedPost #-}
11 | {-# LANGUAGE LambdaCase #-}
12 | {-# LANGUAGE MultiParamTypeClasses #-}
13 | {-# LANGUAGE OverloadedRecordDot #-}
14 | {-# LANGUAGE OverloadedStrings #-}
15 | {-# LANGUAGE PolyKinds #-}
16 | {-# LANGUAGE QualifiedDo #-}
17 | {-# LANGUAGE RankNTypes #-}
18 | {-# LANGUAGE RecordWildCards #-}
19 | {-# LANGUAGE ScopedTypeVariables #-}
20 | {-# LANGUAGE StandaloneKindSignatures #-}
21 | {-# LANGUAGE TypeApplications #-}
22 | {-# LANGUAGE TypeFamilies #-}
23 | {-# LANGUAGE TypeOperators #-}
24 | {-# LANGUAGE UndecidableInstances #-}
25 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
26 |
27 | {-# HLINT ignore "Use if" #-}
28 |
29 | module Okapi.App where
30 |
31 | import Control.Concurrent.Chan qualified as Chan
32 | import Control.Natural qualified as Natural
33 | import Data.Binary.Builder qualified as Builder
34 | import Data.ByteString.Lazy qualified as LBS
35 | import Data.ByteString.Lazy.Char8 qualified as LBSChar8
36 | import Data.Kind
37 | import Data.List qualified as List
38 | import Data.List.NonEmpty qualified as NonEmpty
39 | import Data.Text qualified as Text
40 | import Data.Tree qualified as Tree
41 | import Data.Type.Equality qualified as Equality
42 | import Data.Typeable qualified as Typeable
43 | import Data.Vault.Lazy qualified as Vault
44 | import GHC.Exts qualified as Exts
45 | import GHC.Generics qualified as Generics
46 | import GHC.TypeNats qualified as Nat
47 | import Network.HTTP.Types qualified as HTTP
48 | import Network.Wai qualified as Wai
49 | import Network.Wai.EventSource qualified as Wai
50 | import Network.Wai.Handler.Warp qualified as Warp
51 | import Okapi.Body qualified as Body
52 | import Okapi.Headers qualified as Headers
53 | import Okapi.Middleware qualified as Middleware
54 | import Okapi.Query qualified as Query
55 | import Okapi.Response qualified as Response
56 | import Okapi.Route qualified as Route
57 |
58 | import Text.Regex.TDFA qualified as Regex
59 | import Web.HttpApiData qualified as Web
60 |
61 | type (:->) :: [Type] -> Type -> [Type]
62 | type family (:->) (a :: [Type]) (b :: Type) where
63 | (:->) '[] b = '[b]
64 | (:->) (aa : aas) b = aa : (aas :-> b)
65 |
66 | type Handler :: [Type] -> (Type -> Type) -> Type
67 | type family Handler args env where
68 | Handler '[] env = Wai.Request -> env Wai.Response
69 | Handler (arg : args) env = arg -> Handler args env
70 |
71 | -- TODO: Potentially add type parameter to constrain middleware enum type
72 | data Node (r :: [Type]) where
73 | Choice ::
74 | forall (r :: [Type]).
75 | -- (Typeable.Typeable r) =>
76 | [Node r] ->
77 | Node r
78 | Match ::
79 | forall a (r :: [Type]).
80 | (Web.ToHttpApiData a, Eq a, Typeable.Typeable a, Typeable.Typeable r) =>
81 | a ->
82 | Node r ->
83 | Node r
84 | Param ::
85 | forall a (r :: [Type]).
86 | (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
87 | Node (r :-> a) ->
88 | Node r
89 | Regex ::
90 | forall a (r :: [Type]).
91 | (Regex.RegexContext Regex.Regex Text.Text a, Typeable.Typeable a, Typeable.Typeable r) =>
92 | Text.Text ->
93 | Node (r :-> a) ->
94 | Node r
95 | Splat ::
96 | forall a (r :: [Type]).
97 | (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
98 | Node (r :-> NonEmpty.NonEmpty a) ->
99 | Node r
100 | Route ::
101 | forall a (r :: [Type]).
102 | (Route.From a, Typeable.Typeable a, Typeable.Typeable r) =>
103 | Node (r :-> a) ->
104 | Node r
105 | Query ::
106 | forall a (r :: [Type]).
107 | (Query.From a, Typeable.Typeable a, Typeable.Typeable r) =>
108 | Node (r :-> a) ->
109 | Node r
110 | Headers ::
111 | forall a (r :: [Type]).
112 | (Headers.From a, Typeable.Typeable a, Typeable.Typeable r) =>
113 | Node (r :-> a) ->
114 | Node r
115 | Body ::
116 | forall a (r :: [Type]).
117 | (Body.From a, Typeable.Typeable a, Typeable.Typeable r) =>
118 | Node (r :-> a) ->
119 | Node r
120 | Apply ::
121 | forall t (r :: [Type]).
122 | (Middleware.Tag t, Eq t, Typeable.Typeable t, Typeable.Typeable r) =>
123 | t ->
124 | Node r ->
125 | Node r
126 | Responder ::
127 | forall (status :: Nat.Nat) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
128 | ( Nat.KnownNat status
129 | , Typeable.Typeable status
130 | , Response.WaiResponseHeaders headerKeys
131 | , Response.ContentType contentType
132 | , Response.ToContentType contentType resultType
133 | , Typeable.Typeable headerKeys
134 | , Typeable.Typeable contentType
135 | , Typeable.Typeable resultType
136 | , Typeable.Typeable r
137 | ) =>
138 | Node (r :-> (Response.Headers headerKeys -> resultType -> Wai.Response)) ->
139 | Node r
140 | Events ::
141 | forall (r :: [Type]).
142 | (Typeable.Typeable r) =>
143 | Chan.Chan Wai.ServerEvent ->
144 | Node r
145 | Method ::
146 | forall env (r :: [Type]).
147 | (Typeable.Typeable r) =>
148 | HTTP.StdMethod ->
149 | (env Natural.~> IO) ->
150 | Handler r env ->
151 | Node r
152 |
153 | -- TODO: Add tags to method/handlers like in reitit (Clojure)
154 |
155 | combine ::
156 | forall (r :: [Type]).
157 | (Typeable.Typeable r) =>
158 | Node r ->
159 | Node r ->
160 | Maybe (Node r)
161 | combine n1 n2 = case (n1, n2) of
162 | (Choice @r1 children1, Choice @r2 children2) -> case (Typeable.eqT @r1 @r2) of
163 | Just Typeable.Refl -> Just $ choice @r1 (children1 <> children2)
164 | _ -> Nothing
165 | (Match @a1 @r1 x child1, Match @a2 @r2 y child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
166 | (Just Typeable.Refl, Just Typeable.Refl) -> if x == y then Just $ match @a1 @r1 x $ choice @r1 [child1, child2] else Nothing
167 | (_, _) -> Nothing
168 | (Param @a1 @r1 child1, Param @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
169 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ param @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
170 | (_, _) -> Nothing
171 | (Regex @a1 @r1 regex1 child1, Regex @a2 @r2 regex2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2, regex1 == regex2) of
172 | (Just Typeable.Refl, Just Typeable.Refl, True) -> Just $ regex @a1 @r1 regex1 $ choice @(r1 :-> a1) [child1, child2]
173 | (_, _, _) -> Nothing
174 | (Splat @a1 @r1 child1, Splat @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
175 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ splat @a1 @r1 $ choice @(r1 :-> NonEmpty.NonEmpty a1) [child1, child2]
176 | (_, _) -> Nothing
177 | (Route @a1 @r1 child1, Route @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
178 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ route @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
179 | (_, _) -> Nothing
180 | (Query @a1 @r1 child1, Query @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
181 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ query @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
182 | (_, _) -> Nothing
183 | (Headers @a1 @r1 child1, Headers @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
184 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ headers @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
185 | (_, _) -> Nothing
186 | (Body @a1 @r1 child1, Body @a2 @r2 child2) -> case (Typeable.eqT @a1 @a2, Typeable.eqT @r1 @r2) of
187 | (Just Typeable.Refl, Just Typeable.Refl) -> Just $ body @a1 @r1 $ choice @(r1 :-> a1) [child1, child2]
188 | (_, _) -> Nothing
189 | (Apply @t1 @r1 tag1 node1, Apply @t2 @r2 tag2 node2) -> case (Typeable.eqT @t1 @t2, Typeable.eqT @r1 @r2) of
190 | (Just Typeable.Refl, Just Typeable.Refl) -> case tag1 == tag2 of
191 | True -> Just $ apply @t1 @r1 tag1 $ choice @r1 [node1, node2]
192 | False -> Nothing
193 | (_, _) -> Nothing
194 | (Responder @s1 @hk1 @ct1 @rt1 @r1 child1, Responder @s2 @hk2 @ct2 @rt2 @r2 child2) -> case (Typeable.eqT @s1 @s2, Typeable.eqT @hk1 @hk2, Typeable.eqT @ct1 @ct2, Typeable.eqT @rt1 @rt2, Typeable.eqT @r1 @r2) of
195 | (Just Typeable.Refl, Just Typeable.Refl, Just Typeable.Refl, Just Typeable.Refl, Just Typeable.Refl) -> Just $ responder @s1 @hk1 @ct1 @rt1 @r1 $ choice @(r1 :-> (Response.Headers hk1 -> rt1 -> Wai.Response)) [child1, child2]
196 | (_, _, _, _, _) -> Nothing
197 | (Choice @r1 children, a2') -> Just $ choice @r1 (children <> [a2'])
198 | (a1', Choice @r2 children) -> Just $ choice @r2 (a1' : children)
199 | -- Method is not comparable
200 | (_, _) -> Nothing
201 |
202 | flatten :: (Typeable.Typeable r) => Node r -> Node r
203 | flatten (Choice [node]) = node
204 | flatten (Choice (node1 : node2 : nodes)) = case node1 `combine` node2 of
205 | Just newNode -> flatten $ choice (newNode : nodes)
206 | Nothing ->
207 | choice
208 | [ flatten $ choice (node1 : nodes)
209 | , flatten $ choice (node2 : nodes)
210 | , flatten $ choice nodes
211 | ]
212 | flatten node = node
213 |
214 | choice ::
215 | forall (r :: [Type]).
216 | -- (Typeable.Typeable r) =>
217 | [Node r] ->
218 | Node r
219 | choice = Choice @r
220 |
221 | match ::
222 | forall a (r :: [Type]).
223 | (Web.ToHttpApiData a, Eq a, Typeable.Typeable a, Typeable.Typeable r) =>
224 | a ->
225 | Node r ->
226 | Node r
227 | match = Match @a @r
228 |
229 | lit ::
230 | forall (r :: [Type]).
231 | (Typeable.Typeable r) =>
232 | Text.Text ->
233 | Node r ->
234 | Node r
235 | lit = match @Text.Text
236 |
237 | param ::
238 | forall a (r :: [Type]).
239 | (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
240 | Node (r :-> a) ->
241 | Node r
242 | param = Param @a @r
243 |
244 | regex ::
245 | forall a (r :: [Type]).
246 | (Regex.RegexContext Regex.Regex Text.Text a, Typeable.Typeable a, Typeable.Typeable r) =>
247 | Text.Text ->
248 | Node (r :-> a) ->
249 | Node r
250 | regex = Regex @a @r
251 |
252 | splat ::
253 | forall a (r :: [Type]).
254 | (Web.FromHttpApiData a, Typeable.Typeable a, Typeable.Typeable r) =>
255 | Node (r :-> NonEmpty.NonEmpty a) ->
256 | Node r
257 | splat = Splat @a @r
258 |
259 | route ::
260 | forall a (r :: [Type]).
261 | (Route.From a, Typeable.Typeable a, Typeable.Typeable r) =>
262 | Node (r :-> a) ->
263 | Node r
264 | route = Route @a @r
265 |
266 | query ::
267 | forall a (r :: [Type]).
268 | (Query.From a, Typeable.Typeable a, Typeable.Typeable r) =>
269 | Node (r :-> a) ->
270 | Node r
271 | query = Query @a @r
272 |
273 | headers ::
274 | forall a (r :: [Type]).
275 | (Headers.From a, Typeable.Typeable a, Typeable.Typeable r) =>
276 | Node (r :-> a) ->
277 | Node r
278 | headers = Headers @a @r
279 |
280 | body ::
281 | forall a (r :: [Type]).
282 | (Body.From a, Typeable.Typeable a, Typeable.Typeable r) =>
283 | Node (r :-> a) ->
284 | Node r
285 | body = Body @a @r
286 |
287 | apply ::
288 | forall t (r :: [Type]).
289 | (Middleware.Tag t, Eq t, Typeable.Typeable t, Typeable.Typeable r) =>
290 | t ->
291 | Node r ->
292 | Node r
293 | apply = Apply @t @r
294 |
295 | scope ::
296 | forall a t (r :: [Type]).
297 | (Route.From a, Typeable.Typeable a, Middleware.Tag t, Eq t, Typeable.Typeable t, Typeable.Typeable r) =>
298 | t ->
299 | Node (r :-> a) ->
300 | Node r
301 | scope tag children = apply @t @r tag $ route @a @r children
302 |
303 | responder ::
304 | forall (status :: Nat.Nat) (headerKeys :: [Exts.Symbol]) (contentType :: Type) (resultType :: Type) (r :: [Type]).
305 | ( Nat.KnownNat status
306 | , Typeable.Typeable status
307 | , Response.WaiResponseHeaders headerKeys
308 | , Response.ContentType contentType
309 | , Response.ToContentType contentType resultType
310 | , Typeable.Typeable headerKeys
311 | , Typeable.Typeable contentType
312 | , Typeable.Typeable resultType
313 | , Typeable.Typeable r
314 | ) =>
315 | Node (r :-> (Response.Headers headerKeys -> resultType -> Wai.Response)) ->
316 | Node r
317 | responder = Responder @status @headerKeys @contentType @resultType @r
318 |
319 | method ::
320 | forall env (r :: [Type]).
321 | (Typeable.Typeable r) =>
322 | HTTP.StdMethod ->
323 | (env Natural.~> IO) ->
324 | Handler r env ->
325 | Node r
326 | method = Method @env @r
327 |
328 | endpoint ::
329 | forall a env (r :: [Type]).
330 | (Route.From a, Typeable.Typeable a, Typeable.Typeable r, Typeable.Typeable (r :-> a)) =>
331 | HTTP.StdMethod ->
332 | (env Natural.~> IO) ->
333 | Handler (r :-> a) env ->
334 | Node r
335 | endpoint stdMethod transformation handler =
336 | route @a $ method @env @(r :-> a) stdMethod transformation handler
337 |
338 | any ::
339 | forall env (r :: [Type]).
340 | (Typeable.Typeable r) =>
341 | (env Natural.~> IO) ->
342 | Handler r env ->
343 | Node r
344 | any transformation handler =
345 | choice
346 | [ Method @env @r stdMethod transformation handler
347 | | stdMethod <- [minBound ..]
348 | ]
349 |
350 | events ::
351 | forall (r :: [Type]).
352 | (Typeable.Typeable r) =>
353 | Chan.Chan Wai.ServerEvent ->
354 | Node r
355 | events = Events @r
356 |
357 | data HList (l :: [Type]) where
358 | HNil :: HList '[]
359 | HCons :: e -> HList l -> HList (e ': l)
360 |
361 | snoc :: forall (l :: [Type]) (e :: Type). HList l -> e -> HList (l :-> e)
362 | snoc HNil x = HCons x HNil
363 | snoc (HCons h t) x = HCons h (snoc t x)
364 |
365 | fillHandler :: Handler args env -> HList args -> (Wai.Request -> env Wai.Response)
366 | fillHandler handler HNil = handler
367 | fillHandler handler (HCons x xs) = fillHandler (handler x) xs
368 |
369 | withDefault :: Node '[] -> Wai.Middleware
370 | withDefault = withDefaultLoop id HNil
371 |
372 | withDefaultLoop :: Wai.Middleware -> HList args -> Node args -> Wai.Middleware
373 | withDefaultLoop middleware args root backup request respond = case root of
374 | Choice [] -> backup request respond
375 | Choice (node : nodes) -> case node of
376 | Choice subNodes -> withDefaultLoop middleware args (choice (subNodes <> nodes)) backup request respond
377 | Match value subNode ->
378 | case Wai.pathInfo request of
379 | [] -> withDefaultLoop middleware args (choice nodes) backup request respond
380 | (pathHead : pathTail) ->
381 | if pathHead == Web.toUrlPiece value
382 | then do
383 | let newRequest = request{Wai.pathInfo = pathTail}
384 | withDefaultLoop middleware args subNode backup newRequest respond
385 | else withDefaultLoop middleware args (choice nodes) backup request respond
386 | Param @p subNode ->
387 | case Wai.pathInfo request of
388 | [] -> withDefaultLoop middleware args (choice nodes) backup request respond
389 | (pathHead : pathTail) ->
390 | case Web.parseUrlPiece @p pathHead of
391 | Left _ -> withDefaultLoop middleware args (choice nodes) backup request respond
392 | Right value -> do
393 | let newRequest = request{Wai.pathInfo = pathTail}
394 | withDefaultLoop middleware (snoc args value) subNode backup newRequest respond
395 | Responder @s @hk @ct @rt @r subNode ->
396 | let callback = Response.makeResponder @s @hk @ct @rt
397 | in withDefaultLoop
398 | middleware
399 | (snoc args callback)
400 | (choice [subNode])
401 | (withDefaultLoop middleware args (choice nodes) backup)
402 | request
403 | respond
404 | Method stdMethod transformation handler ->
405 | case HTTP.parseMethod $ Wai.requestMethod request of
406 | Left _ -> withDefaultLoop middleware args (choice nodes) backup request respond
407 | Right stdMethod' ->
408 | if stdMethod == stdMethod' && List.null (Wai.pathInfo request)
409 | then
410 | middleware
411 | ( \request' respond' -> do
412 | response <- transformation $ fillHandler handler args request'
413 | respond' response
414 | )
415 | request
416 | respond
417 | else withDefaultLoop middleware args (choice nodes) backup request respond
418 | Events source ->
419 | middleware
420 | ( \request' respond' -> Wai.eventSourceAppChan source request' respond'
421 | )
422 | request
423 | respond
424 | root' -> withDefaultLoop middleware args (choice [root']) backup request respond
425 |
426 | ---- TODO: May need system for content-type negotiation???
427 | ---- The accepted content types can be the same or more
428 | ---- If Accept is less than the responseses content types, then I can't go down that tree
429 |
430 | {-
431 | stringify :: Tree -> IO (Node.Tree String)
432 | stringify [] = return []
433 | stringify (tree:remForest) = case tree of
434 | Match value subForest -> do
435 | stringSubForest <- stringify subForest
436 | stringRemForest <- stringify remForest
437 | let string = "/" <> (Text.unpack $ Web.toUrlPiece value)
438 | return ((Tree.Node string stringSubForest) : stringRemForest)
439 | Param @t growSubForest -> do
440 | secret <- Secret.new @t
441 | stringSubForest <- stringify $ growSubForest secret
442 | stringRemForest <- stringify remForest
443 | let string = "/:" <> showType @t
444 | return ((Tree.Node string stringSubForest) : stringRemForest)
445 | Regex @t regex growSubForest -> do
446 | secret <- Secret.new @t
447 | stringSubForest <- stringify $ growSubForest secret
448 | stringRemForest <- stringify remForest
449 | let string = "/<" <> Text.unpack regex <> ">"
450 | return ((Tree.Node string stringSubForest) : stringRemForest)
451 | Splat @t growSubForest -> do
452 | secret <- Secret.new @(NonEmpty.NonEmpty ty)
453 | forest <- mapM $ produce secret
454 | return $ Tree.Node ("/*" <> showType @ty) forest
455 | (Route @ty route produce) = do
456 | secret <- Secret.new @ty
457 | forest <- mapM $ produce secret
458 | return $ Tree.Node (Text.unpack (Route.rep route)) forest
459 | (Method m _ _) = do
460 | return $ Tree.Node (show m) []
461 | (Apply _ api) = do
462 | (Tree.Node root subTrees) <- api
463 | return $ Tree.Node ("(" <> root <> ")") subTrees
464 | -}
465 |
466 | {-
467 | forest :: Tree -> IO (Tree.Node String)
468 | forest [] = return $ Tree.Node ":root:" []
469 | forest apis = do
470 | forest' <- mapM tree apis
471 | return $ Tree.Node "\ESC[31m:root:\ESC[0m" forest'
472 | where
473 | tree :: Node -> IO (Tree.Node String)
474 | tree (Match value apis) = do
475 | forest <- mapM tree apis
476 | return $ Tree.Node ("/" <> (Text.unpack $ Web.toUrlPiece value)) forest
477 | tree (Param @ty produce) = do
478 | secret <- Secret.new @ty
479 | forest <- mapM tree $ produce secret
480 | return $ Tree.Node ("/:" <> showType @ty) forest
481 | tree (Regex @ty regex produce) = do
482 | secret <- Secret.new @ty
483 | forest <- mapM tree $ produce secret
484 | return $ Tree.Node ("/r<" <> Text.unpack regex <> ">") forest
485 | tree (Splat @ty produce) = do
486 | secret <- Secret.new @(NonEmpty.NonEmpty ty)
487 | forest <- mapM tree $ produce secret
488 | return $ Tree.Node ("/*" <> showType @ty) forest
489 | tree (Route @ty route produce) = do
490 | secret <- Secret.new @ty
491 | forest <- mapM tree $ produce secret
492 | return $ Tree.Node (Text.unpack (Route.rep route)) forest
493 | tree (Method m _ _) = do
494 | return $ Tree.Node (show m) []
495 | tree (Apply _ api) = do
496 | (Tree.Node root subTrees) <- tree api
497 | return $ Tree.Node ("(" <> root <> ")") subTrees
498 |
499 | showType :: forall a. (Typeable.Typeable a) => String
500 | showType = show . Typeable.typeRep $ Typeable.Proxy @a
501 |
502 | get_ = method HTTP.GET
503 |
504 | getIO_ = method HTTP.GET id
505 | -}
506 |
--------------------------------------------------------------------------------
/docs/index.md:
--------------------------------------------------------------------------------
1 | # ┌───────┐
2 | # │ Okapi │
3 | # └───────┘
4 |
5 | Okapi is a micro framework for HTTP servers.
6 |
7 | - Ergonomic DSL for parsing requests
8 | - Integrates seamlessly with ANY monad stack or effect system
9 | - Automagically generate OpenAPI specifications (clients coming soon)
10 | - Lightweight abstraction built on top of [WAI](https://hackage.haskell.org/package/wai)
11 |
12 | **Okapi is NOT recommended for production use at this time.**
13 |
14 | Please feel free to reach out to me on [GitHub](https://github.com/monadicsystems/okapi) if you have any questions/criticisms/ideas or would like to contribute to this project.
15 |
16 | ---
17 |
18 | ## Getting Started
19 |
20 | 1. Use the command `stack new ` to create a new Haskell project
21 | 2. Add the `okapi` library to your project's dependencies
22 |
23 | ***
24 |
25 | ## Introduction
26 |
27 | There are two ways to implement *Servers* in Okapi.
28 |
29 | The recommended way to implement a Server in Okapi is via *Endpoints*:
30 |
31 | ```haskell
32 | -- | Define Endpoints using an Applicative eDSL
33 | myEndpoint = Endpoint
34 | { method = GET
35 | , path = do
36 | Path.static "index"
37 | magicNumber <- Path.param @Int
38 | pure magicNumber
39 | , query = do
40 | x <- Query.param @Int "x"
41 | y <- Query.option 10 $ Query.param @Int "y"
42 | pure (x, y)
43 | , body = do
44 | foo <- Body.json @Value
45 | pure foo
46 | , headers = pure ()
47 | , responder = do
48 | itsOk <- Responder.json @Int status200 do
49 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
50 | pure addSecretNumber
51 | pure itsOk
52 | }
53 | ```
54 |
55 | An alternative, more concise way of defining a Server in Okapi is via *Matchpoints*:
56 |
57 | ```haskell
58 | -- | Define Matchpoint patterns using PatternSynonyms,
59 | -- ViewPatterns, and the same eDSL used for Endpoints
60 | pattern GetUsers optF <- Matchpoint
61 | GET
62 | ["users"]
63 | _
64 | (Body.eval $ Body.optional $ Body.json @Filter -> Ok optF)
65 | _
66 |
67 | pattern AddUser user <- Matchpoint
68 | POST -- Method
69 | ["users"] -- Path
70 | _ -- Query
71 | (Body.eval $ Body.json @User -> Ok user) -- Body
72 | _ -- Headers
73 |
74 | pattern GetUsersByID userID <- Matchpoint
75 | GET
76 | (Path.eval $ Path.static "users" *> Path.param @UserID -> Ok userID)
77 | _
78 | ""
79 | _
80 |
81 | -- | Servers are just contextful functions from a Request to a Response
82 | type Server m = Request -> m Response
83 |
84 | myServer :: Server IO
85 | myServer = \case
86 | GetUser -> do
87 | ...
88 | GetUserByID userID -> do
89 | ...
90 | AddUser user -> do
91 | ...
92 | _ -> do
93 | ...
94 |
95 | -- | Run your Server using Warp
96 | main = Warp.run 3000 $ instantiate id myServer
97 | ```
98 |
99 | The advantadge of using Endpoints over Matchpoints is that Okapi can
100 | automatically generate *Specifications* and *Clients* for a Server implemented
101 | with Endpoints, but not a Server implemented with Matchpoints.
102 |
103 | On the flip side, a Server implemented with Matchpoints will be more
104 | concise than the same Server implemented with Endpoints.
105 |
106 | ___
107 |
108 | ## Endpoint
109 |
110 | An Endpoint is an *executable specification* representing a single Operation that can be taken against your API.
111 |
112 | An Endpoint has 6 fields.
113 |
114 | ```haskell
115 | data Endpoint p q h b r = Endpoint
116 | { method :: StdMethod -- (1)
117 | , path :: Path.Script p -- (2)
118 | , query :: Query.Script q -- (3)
119 | , body :: Body.Script b -- (4)
120 | , headers :: Headers.Script h -- (5)
121 | , responder :: Responder.Script r -- (6)
122 | }
123 | ```
124 |
125 | The `method` field is a simple value, but the other fields point to what's called a *Script*. Scripts represent Okapi's DSL for extracting and parsing data from Requests. There's a specific type of Script for each part of a Request.
126 |
127 | The type parameter of a Script represents the type of value it returns.
128 |
129 | Therefore, the concrete type of an Endpoint is determined by the return types of
130 | the Scripts that are used to construct the Endpoint.
131 |
132 | All the different Script types are Applicatives, but not all are *lawful Applicatives*.
133 |
134 | Since all Script types are Applicatives, we can use the Applicative typeclass methods to write our Scripts. Here's an example of a Query Script.
135 |
136 | ```haskell
137 | data Filter = Filter
138 | { color :: Text
139 | , categoryID :: Int
140 | , isOnSale :: Maybe ()
141 | }
142 |
143 | myQueryScript :: Query.Script Filter
144 | myQueryScript = Filter
145 | <$> Query.param "color"
146 | <*> Query.param "category"
147 | <*> (Query.optional $ Query.flag "sale")
148 | ```
149 |
150 | If you have the `-XApplicativeDo` language extension turned on, you can also write your Scripts using `do` syntax.
151 |
152 | We recommend using `-XApplicativeDo` in conjuction with the `-XRecordWildCards` language extension if you're not comfortable with using the Applicative operators. Here's the same Query Script we defined above, but with these language extensions turned on.
153 |
154 | ```haskell
155 | {-# LANGUAGE ApplicativeDo #-}
156 | {-# LANGUAGE RecordWildCards #-}
157 |
158 | myQueryScript :: Query.Script Filter
159 | myQueryScript = do
160 | color <- Query.param "color"
161 | categoryID <- Query.param "category"
162 | isOnSale <- Query.optional $ Query.flag "sale"
163 | pure Filter {..}
164 | ```
165 |
166 | Each Script type has its own operations suited to parsing its respective part of the
167 | Request. These operations are covered in more detail below.
168 |
169 | 1. #### Method
170 |
171 | The `method` field represents the HTTP Method that the Endpoint accepts.
172 |
173 | Its type is `StdMethod` from the `http-types` library.
174 |
175 | [HTTP standard method (as defined by RFC 2616, and PATCH which is defined by RFC 5789).](https://hackage.haskell.org/package/http-types-0.12.3/docs/Network-HTTP-Types-Method.html#t:StdMethod)
176 |
177 | 2. #### Path Script
178 |
179 | The `path` field defines the Request Path that the Endpoint accepts, including Path parameters.
180 |
181 | Path Scripts have two operations: `static` and `param`.
182 |
183 | ```haskell
184 | myPathScript = Path.static "person" *> Path.param @Int "personID"
185 | ```
186 |
187 | 3. #### Query Script
188 |
189 | The `query` field defines the Query that the Endpoint accepts.
190 |
191 | There are two operations for Query Scripts: `param` and `flag`.
192 |
193 | There are two modifiers for Query Scripts: `optional` and `option`.
194 |
195 | `optional` and `option` are specialized versions of the `optional` and `option`
196 | parser combinators found in the `parser-combinators` library.
197 |
198 | ```haskell
199 | myQueryScript :: Query.Script (Text, Maybe Float, Int)
200 | myQueryScript = do
201 | lastName <- Query.param "last_name"
202 | optSalary <- Query.optional $ Query.param "salary"
203 | minAge <- Query.option 21 $ Query.param "min_age"
204 | pure (lastName, optSalary, minAge)
205 | ```
206 |
207 | 4. #### Body Script
208 |
209 | The `body` field defines the Request Body that the Endpoint accepts.
210 |
211 | There are four operations for Body Scripts: `json`, `form`, `param`, `file`.
212 |
213 | There are two modifiers for Body Scripts: `optional` and `option`.
214 |
215 | ```haskell
216 | myBodyScript :: Body.Script (Maybe Value)
217 | myBodyScript = Body.optional $ Body.json @Value
218 | ```
219 |
220 | 5. #### Headers Script
221 |
222 | The `headers` field defines the Request Headers that the Endpoint accepts.
223 |
224 | There are two operations for Headers Scripts: `param` and `cookie`.
225 |
226 | There are two modifiers for Headers Scripts: `optional` and `option`.
227 |
228 | ```haskell
229 | myHeadersScript :: Headers.Script _
230 | myHeadersScript = undefined
231 | ```
232 |
233 | 6. #### Responder Script
234 |
235 | The `responder` field defines the Responses that the Endpoint's handler MUST return.
236 |
237 | Responder Scripts have to be more complex than the other Script types in order for the Endpoint to have a contract with its Handler. The contract ensures that the Handler will respond with the Responses defined in the Responder Script.
238 |
239 | This is done using a combination of higher order functions, linear types, and smart constructors.
240 |
241 | Responder Script operations have to take an *Add Header Script* as an argument to define what Headers will be attached to the Response.
242 |
243 | For now, there is only one operation for Responder Scripts: `json`.
244 |
245 | Add Header Scripts only have one operation as well: `using`.
246 |
247 | ```haskell
248 | {-# LANGUAGE ApplicativeDo #-}
249 | {-# LANGUAGE RecordWildCards #-}
250 | {-# LANGUAGE BlockArguments #-}
251 | {-# LANGUAGE LinearTypes #-}
252 |
253 | data SecretHeaders = SecretHeaders
254 | { firstSecret :: Int -> Response -> Response
255 | , secondSecret :: Int -> Response -> Response
256 | }
257 |
258 | data MyResponders = MyResponders
259 | { allGood :: (SecretHeaders %1 -> Response -> Response) -> Text -> Response
260 | , notGood :: (() %1 -> Response -> Response) -> Text -> Response
261 | }
262 |
263 | myResponderScript = do
264 | allGood <- Responder.json @Text status200 do
265 | addSecret <- AddHeader.using @Int "IntSecret"
266 | addAnotherSecret <- AddHeader.using @Int "X-Another-Secret"
267 | pure SecretHeaders {..}
268 | notGood <- Responder.json @Text status501 $ pure ()
269 | pure MyResponders {..}
270 |
271 | myHandler someNumber _ _ _ _ (MyResponders allGood notGood) = do
272 | if someNumber < 100
273 | then return $ allGood
274 | (\(SecretHeaders firstSecret secondSecret) response -> secondSecret 0 $ firstSecret 7 response)
275 | "All Good!"
276 | else return $ notGood
277 | (\() response -> response)
278 | "Not Good!"
279 | ```
280 |
281 | More information about *Responder* and *AddHeader* are available in the Handler section.
282 |
283 | ### Handler
284 |
285 | Handlers are simple: they are contextful functions from the arguments provided by an Endpoint, to a Response.
286 |
287 | The type synonym `Handler` represents the type of these contextful functions.
288 |
289 | ```haskell
290 | type Handler m p q b h r = p -> q -> b -> h -> r -> m Response
291 | ```
292 |
293 | The type parameter `m` represents the context in which the Handler creates the Response.
294 |
295 | The type parameters `p`, `q`, `b`, `h` and `r` represent the types of the values returned by the Endpoint's Path, Query, Body, Headers and Responder Scripts respectively.
296 |
297 | ### Plan
298 |
299 | A Plan is how your Endpoint and its designated Handler come together.
300 |
301 | ```haskell
302 | data Plan m p q h b r = Plan
303 | { transformer :: m ~> IO
304 | , endpoint :: Endpoint p q h b r
305 | , handler :: Monad m => p -> q -> b -> h -> r -> m Response
306 | }
307 | ```
308 |
309 | The `transformer` field represents a *natural transformation* from your Handler's Monad `m`, to `IO`. This is where you decide how your custom effects are interpreted in an `IO` context.
310 |
311 | The `endpoint` field represents your Endpoint.
312 |
313 | The `handler` field represents your Handler. The types must match the types of your `endpoint` and `transformer`.
314 |
315 | Here's an example of a `Plan`:
316 |
317 | ```haskell
318 | myPlan = Plan
319 | { transformer = id
320 | , endpoint = myEndpoint
321 | , handler = myHandler
322 | }
323 |
324 | myEndpoint = Endpoint
325 | { method = GET
326 | , path = do
327 | Path.static "index"
328 | magicNumber <- Path.param @Int
329 | pure magicNumber
330 | , query = do
331 | x <- Query.param @Int "x"
332 | y <- Query.option 10 $ Query.param @Int "y"
333 | pure (x, y)
334 | , body = do
335 | foo <- Body.json @Value
336 | pure foo
337 | , headers = pure ()
338 | , responder = do
339 | itsOk <- Responder.json @Int HTTP.status200 do
340 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
341 | pure addSecretNumber
342 | pure itsOk
343 | }
344 |
345 | myHandler magicNumber (x, y) foo () responder = do
346 | let newNumber = magicNumber + x * y
347 | print newNumber
348 | print foo
349 | return $ responder (\addHeader response -> addHeader (newNumber * 100) response) newNumber
350 | ```
351 |
352 | The Server you build will be a combination of many Plans.
353 |
354 | ### Server
355 |
356 | A Server is the final type of value that you need to generate an Application or Specification.
357 |
358 | ```haskell
359 | data Server = Server
360 | { info :: Maybe Info
361 | , defaultResponse :: WAI.Response
362 | , artifacts :: [Artifact]
363 | }
364 | ```
365 |
366 | The `info` field represents your Server's metadata. It's used in the generation of the Server's Specification. It's optional.
367 |
368 | The `artifacts` field is a list of Artifact. A single Artifact is generated from a single Plan. An Artifact contains two values:
369 |
370 | 1. An IO action that returns a Response. It's only executed if the Endpoint used to generate the IO action matches the Request.
371 | 2. An OpenAPI PathItem value based on the structure of the Endpoint used to build the Artifact.
372 |
373 | These two values, when combined with the Server's other Artifacts, are used to generate the final Application and OpenAPI Specification.
374 |
375 | ```haskell
376 | build ::
377 | forall m p q h b r.
378 | Monad m =>
379 | Plan m p q h b r ->
380 | Artifact
381 | build = ...
382 |
383 | plan1 :: Plan A B C D E F
384 | plan1 = ...
385 |
386 | plan2 :: Plan G X Z U I P
387 | plan2 = ...
388 |
389 | plan3 :: Plan Y T L G N Q
390 | plan3 = ...
391 |
392 | myServer = Server
393 | { info = Nothing
394 | , defaultResponse = default404
395 | , artifacts =
396 | [ build plan1
397 | , build plan2
398 | , build plan3
399 | , ...
400 | ]
401 | }
402 | ```
403 |
404 | The types of the Plans used to build your Server don't have to be the same. The `build` function erases the types and gives us the end products we need. This allows us to mix and match various combinations of Endpoints, Handlers, and Monad transformations in the same Server definition. For example, you can have two Handlers that operate in two different Monads in the same Server.
405 |
406 | Now that you have you your Server, you can use it to:
407 |
408 | 1. Generate a WAI Application
409 | 2. Generate an OpenAPI Specification
410 |
411 | ```haskell
412 | myServer :: Server
413 | myServer = ...
414 |
415 | api :: Application
416 | api = genWaiApplication myServer
417 |
418 | apiSpec :: OpenApi
419 | apiSpec = genOpenAPISpec myServer
420 | ```
421 |
422 | In the future, you should be able to automatically generate API clients as well.
423 |
424 | ### Tips & Ideas
425 |
426 | #### Not Using A Plan
427 |
428 | You can also create Servers with out first creating Plans. If you want to do this, you can just use the `buildWith` function directly.
429 |
430 | ```haskell
431 | buildWith ::
432 | forall m p q h b r.
433 | Monad m =>
434 | (m ~> IO) ->
435 | Endpoint p q h b r ->
436 | Handler m p q h b r
437 | Artifact
438 | buildWith transformer endpoint handler = ...
439 | ```
440 |
441 | Assuming all of your handlers for the Server will run in the same context,
442 | you can just partially apply `buildWith` to a transformation function and use the
443 | partially applied function on your Endpoints and Handlers to produce Artifacts.
444 |
445 | ```haskell
446 | buildWithIO = buildWith id
447 |
448 | myServer = Server
449 | { info = Nothing
450 | , defaultResponse = default404
451 | , artifacts =
452 | [ buildWithIO endpoint1 handler1
453 | , buildWithIO endpoint2 handler2
454 | , buildWithIO endpoint3 \x y z a b -> do
455 | doSomethingWith x
456 | log a y b
457 | ...
458 | ]
459 | }
460 | ```
461 |
462 | #### DRY Endpoints
463 |
464 | When implementing an API you will usually need the same path to have multiple methods, each with different parameters in the query, body and headers. Since Endpoints are records, this is easy to deal with. Let's say we have a typical `/users/{userID : UserID}` route that accepts GET and PUT requests for fetching and updating a specific user respectively. The GET variant doesn't need a Body, but the PUT variant will.
465 |
466 | ```haskell
467 | getUser = Endpoint
468 | { method = GET
469 | , path = do
470 | Path.static "users"
471 | userID <- Path.param @UserID
472 | pure userID
473 | , query = pure ()
474 | , body = pure () -- No Body Needed
475 | , headers = pure ()
476 | , responder = do
477 | ... -- The appropriate responses for a GET request
478 | }
479 |
480 | putUser = getUser
481 | { method = PUT
482 | , body = Body.json @UpdatedUser -- Body Needed
483 | , responder = do
484 | ... -- The appropriate responses for a PUT request
485 | }
486 | ```
487 |
488 | This way, we can define the `putUser` Endpoint by simply modifying `getUser` and avoid repeating our self.
489 |
490 | ***
491 |
492 | ## Matchpoint
493 |
494 | A Matchpoint is a *pattern* that matches on Request values.
495 |
496 | ```haskell
497 | pattern Matchpoint :: Request -> Matchpoint
498 | ```
499 |
500 | You can use the Matchpoint pattern synonym to create your own pattern synonyms that match specific Requests.
501 |
502 | ```haskell
503 | newtype UserID = UserID Int
504 | deriving ({- various typeclasses -})
505 |
506 | pattern GetUserByID :: UserID -> Request
507 | pattern GetUserByID userID <- Matchpoint
508 | GET
509 | ["users", PathParam @UserID userID]
510 | _
511 | _
512 | _
513 | ```
514 |
515 | The `GetUserByID` pattern defined above would match against any Request of the form `GET /users/{userID : UserID}`. The Handler on the RHS of this pattern in a case statement will then be able to use the `userID` parameter in its function body if the Request matches sucessfully. If not, the next Matchpoint in your case statement is checked, just like regular patterns that we use all the time.
516 |
517 | `PathParam` is a pattern synonym that you can use in your Matchpoints to match against path parameters of any type that are instances of both `ToHttpApiData` and `FromHttpApiData`. This is required since `PathParam` is a *bidirectional pattern synonym*. This property of `PathParam` makes it useful for generating URLs.
518 |
519 | If your matching logic is more complicated, pattern synonyms alone may not be enough. For more complicated routes, we can use Okapi's DSL inside our Matchpoints by using `-XViewPatterns`. As an example, let's reimplement the first Endpoint on this page as a Matchpoint. Here's the Endpoint version first.
520 |
521 | ```haskell
522 | -- | Define Endpoints using an Applicative eDSL
523 | myEndpoint = Endpoint
524 | { method = GET
525 | , path = do
526 | Path.static "index"
527 | magicNumber <- Path.param @Int
528 | pure magicNumber
529 | , query = do
530 | x <- Query.param @Int "x"
531 | y <- Query.option 10 $ Query.param @Int "y"
532 | pure (x, y)
533 | , body = do
534 | foo <- Body.json @Value
535 | pure foo
536 | , headers = pure ()
537 | , responder = do
538 | itsOk <- Responder.json @Int status200 do
539 | addSecretNumber <- AddHeader.using @Int "X-SECRET"
540 | pure addSecretNumber
541 | pure itsOk
542 | }
543 | ```
544 |
545 | Here's the equivalent Matchpoint version.
546 |
547 | ```haskell
548 | -- | Define Matchpoints using the same DSL
549 | pattern MyMatchpoint magicNumber pair foo = Matchpoint
550 | GET
551 | (Path.eval $ Path.static "index" *> Path.param @Int -> Ok magicNumber)
552 | (Query.eval xyQuery -> Ok pair)
553 | (Body.eval $ Body.json @Value -> Ok foo)
554 | _
555 |
556 | xyQuery = do
557 | x <- Query.param @Int "x"
558 | y <- Query.option 10 $ Query.param @Int "y"
559 | pure (x, y)
560 | ```
561 |
562 | We can simplify `MyMatchpoint` further by using more pattern synonyms.
563 |
564 | ```haskell
565 | pattern MyMatchpoint n pair bar <- Matchpoint
566 | GET
567 | (MagicNumber n)
568 | (XYQuery pair)
569 | (Foo bar)
570 | _
571 |
572 | pattern MagicNumber n <- (Path.eval $ Path.static "index" *> Path.param @Int -> Ok n)
573 |
574 | pattern XYQuery pair <- (Query.eval xyQuery -> Ok pair)
575 |
576 | pattern Foo baz <- (Body.eval $ Body.json @Value -> Ok baz)
577 |
578 | xyQuery = do
579 | x <- Query.param @Int "x"
580 | y <- Query.option 10 $ Query.param @Int "y"
581 | pure (x, y)
582 | ```
583 |
584 | Pattern synonyms like `MagicNumber` or `XYQuery` in the example above come in handy when we need to use the same pattern inside multiple Matchpoints.
585 |
586 | You can use the Matchpoint we defined above in a case statement with other Matchpoints to define a Server.
587 |
588 | ```haskell
589 | type Server m = Request -> m Response
590 |
591 | myServer :: Server IO
592 | myServer = \case
593 | MyMatchpoint n (x, y) foo -> do
594 | ...
595 | _ -> do
596 | ...
597 |
598 | instantiate :: Monad m => (m ~> IO) -> Server m -> Application
599 | instantiate transformer server = ...
600 |
601 | api :: Application
602 | api = instantiate id myServer
603 | ```
604 |
605 | The Server type for Matchpoints is much simpler than the Server type for Endpoints.
606 |
607 | ### Matchpoints vs. Endpoints
608 |
609 | We recommend using Endpoints. Matchpoints are great if you're not worried about safety and just want to get something up and running quickly. Here are some downsides to using Matchpoints to implement your Server:
610 |
611 | 1. We can't perform any static analysis on them. This means you can't generate OpenAPI specifications for Matchpoint Servers or perform any optimizations on them. You can perform static analysis on the Scripts that you use in your Matchpoints though, if there are any.
612 |
613 | 2. All Handlers in a Matchpoint Server must operate within the same context. For Endpoints, this is not the case.
614 |
615 | 3. Endpoints are more modular. You can achieve some level of modularity with your Matchpoints by using nested `-XPatternSynonyms` though.
616 |
617 | 4. Matchpoint Servers have no knowledge of what Responses you will return to the Client. Endpoint Servers know every possible Response you may return from your Handlers, besides the ones returned by `IO` errors (the goal is for Endpoints to know about these as well).
618 |
619 | 5. Requires knowledge of the `-XPatternSynonyms` and `-XViewPatterns` language extensions.
620 |
621 | In short, if you don't care about safety, use Matchpoints.
622 |
623 | ***
624 |
625 | ## Servant <> Okapi
626 |
627 | Coming Soon
628 |
--------------------------------------------------------------------------------