├── shell.nix ├── .gitignore ├── README.md ├── default.nix └── Main.lhs /shell.nix: -------------------------------------------------------------------------------- 1 | (import ./default.nix {}).ghc 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *~ 3 | *.hi 4 | result* 5 | dist -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | servant-from-scratch 2 | ========================= 3 | 4 | Implement a majority subset of both `servant-client` and `servant-server` from scratch using this walkthrough-tutorial. 5 | 6 | ### Build 7 | 8 | ```bash 9 | $ nix-build 10 | ``` 11 | 12 | ### Develop 13 | 14 | ```bash 15 | $ nix-shell 16 | ``` 17 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import {} }: 2 | let 3 | ghc = pkgs.haskellPackages.ghcWithPackages (p: with p; [ aeson aeson-pretty http-client-tls http-client warp wai http-api-data]); 4 | build = pkgs.stdenv.mkDerivation { 5 | name = "servant-from-scratch"; 6 | src = ./.; 7 | buildCommand = '' 8 | mkdir -p $out/{bin,src} 9 | cp $src/Main.lhs Main.lhs 10 | ${ghc}/bin/ghc Main.lhs -o main 11 | mv main $out/bin 12 | mv Main.lhs $out/src 13 | ''; 14 | }; 15 | in 16 | { inherit build ghc; 17 | } 18 | -------------------------------------------------------------------------------- /Main.lhs: -------------------------------------------------------------------------------- 1 | > {-# LANGUAGE UndecidableInstances #-} 2 | > {-# LANGUAGE DerivingStrategies #-} 3 | > {-# LANGUAGE OverloadedStrings #-} 4 | > {-# LANGUAGE DeriveAnyClass #-} 5 | > {-# LANGUAGE TypeOperators #-} 6 | > {-# LANGUAGE TypeApplications #-} 7 | > {-# LANGUAGE ScopedTypeVariables #-} 8 | > {-# LANGUAGE LambdaCase #-} 9 | > {-# LANGUAGE RecordWildCards #-} 10 | > {-# LANGUAGE DataKinds #-} 11 | > {-# LANGUAGE PolyKinds #-} 12 | > {-# LANGUAGE TypeFamilies #-} 13 | > {-# LANGUAGE FlexibleInstances #-} 14 | > {-# LANGUAGE DeriveGeneric #-} 15 | > ------------------------------------ 16 | > -- | Talk: Servant-from-scratch 17 | > -- Date: May 20, 2020 18 | > -- Description: 19 | > -- A pedagogical implementation of servant-client. 20 | > -- This talk describes DSLs, generic programming, 21 | > -- Haskell extensions, servant's grammar and 22 | > -- a simpler implementation of servant-client. 23 | > ----------------------------------- 24 | > module Main where 25 | 26 | > import Control.Monad 27 | > import Control.Applicative 28 | > import Data.Aeson 29 | > import Data.Aeson.Encode.Pretty 30 | > import qualified Data.ByteString.Char8 as B8 31 | > import qualified Data.ByteString.Lazy.Char8 as BL8 32 | > import qualified Data.Text as T 33 | > import Data.Text (Text) 34 | > import qualified Data.Text.Encoding as T 35 | > import Data.List 36 | > import Data.Proxy 37 | > import GHC.Generics 38 | > import GHC.TypeLits 39 | > import Network.HTTP.Client hiding (Proxy, path, Response) 40 | > import Network.HTTP.Client.TLS 41 | > import Network.HTTP.Types.Status 42 | > import Network.Wai hiding (queryString, requestHeaders, responseStatus, requestBody) 43 | > import Web.HttpApiData 44 | > import Network.Wai.Handler.Warp (run) 45 | 46 | 47 | Nice to see where we're going before we get there. 48 | Our goal is to build the following http(s)-client using 'servant' from scratch. 49 | and servant-server (with Wai) 50 | 51 | > main :: IO () 52 | > main = do 53 | > -- submit $ getEcho (Just "bar") (Just "quux") 54 | > submit (postEcho alice) 55 | > -- submit (postEcho bob) 56 | > runServer 57 | 58 | > -- ### What is servant? 59 | 60 | Servant is a collection of libraries used for web programming (created by Haskell devs in Singapore). 61 | The 'core' servant package is 'servant', and all other packages depend on servant to implement their functionality. 62 | 63 | Servant can be described as an extensible embedded domain specific language. This just means it isn't a full language (i.e. like Haskell / Purescript), but a domain-specific one. "Embedded" means this langauge exists inside the host language (Haskell in this case). Furthermore, it is embedded at the type-level. This might seem like an odd choice because there is not as much (albeit still a lot) expressive power at the type-level, as the value level. Haskell is not the best language for type-level programming (see Idris, Agda, Coq), but Haskell is the most practical functional programming language for real-world work, and therefore learning the type-level facilities it provides to us can be very beneficial for day-to-day work. In summary, servant is an embedded domain specific langauge, where the domain is Web programming. 64 | 65 | > -- ### Why is Servant at the type-level? 66 | 67 | - 1) We can encode invariants about what our web server should do, what kinds of serialization constraints should be present on our business logic. 68 | - 2) Can throw compile errors when something is wrong (as opposed to runtime errors). 69 | - 3) Let the compiler generate the code for us (form or meta-programming) 70 | 71 | > -- ### Combinators 72 | 73 | - Allows us to combine terms in our grammar 74 | 75 | > -- ### Alternative 76 | 77 | -- Used in servant to demarcate different routes 78 | -- "GET /api/cats" :<|> "POST /api/cats" 79 | 80 | > data left :<|> right = left :<|> right 81 | > infixr 3 :<|> 82 | 83 | > -- ### Sub 84 | 85 | -- Used in servant to string terms together. Combinators. 86 | -- "api" :> "cats" :> Get '[JSON] Value 87 | -- "api" :> "cats" :> QueryParam "ishappy" Bool :> Get '[JSON] Value 88 | 89 | > data (a :: k) :> b 90 | > infixr 4 :> 91 | 92 | > -- ### Content-Types 93 | 94 | -- Notice only a single type, no value-level. Yet still useful to us. 95 | 96 | > data JSON 97 | 98 | > -- ### Method 99 | 100 | -- Used at both type-level and value-level thanks to promotion from DataKinds 101 | -- https://www.seas.upenn.edu/~sweirich/papers/tldi12.pdf 102 | -- 103 | -- GET is a value, but also promoted as a type. Thanks to DataKinds 104 | -- 105 | -- λ> :type GET -- type of the value 106 | -- GET :: Method 107 | -- 108 | -- λ> :kind 'GET -- type of the type 109 | -- 'GET :: Method 110 | 111 | > data Method 112 | > = GET 113 | > | PUT 114 | > | POST 115 | > | DELETE 116 | > | PATCH 117 | > deriving (Show, Eq) 118 | 119 | > -- ### Capture 120 | 121 | -- Allows variable substitution in a path fragment 122 | -- GET /api/dog/{name} 123 | -- Capture "name" String 124 | 125 | > data Capture 126 | > (name :: Symbol) 127 | > (capType :: a) 128 | 129 | > -- ### QueryParam 130 | 131 | -- GET /api/dog?ishappy=true 132 | 133 | > data QueryParam 134 | > (name :: Symbol) 135 | > (qType :: a) 136 | 137 | > -- # ReqBody 138 | 139 | -- POST /api/dog '{ \"type\" : \"Dachshund\", \"name\" : \"Rex\" }' 140 | 141 | > data ReqBody 142 | > (ctypes :: [*]) 143 | > (reqBodyType :: *) 144 | 145 | > -- # Verb 146 | 147 | -- POST /api/dog '{ \"type\" : \"Dachshund\", \"name\" : \"Rex\" }' 148 | 149 | > data Verb 150 | > (method :: Method) 151 | > (ctypes :: [*]) 152 | > (returnType :: a) 153 | 154 | > -- # Type synonyms 155 | 156 | > type Get = Verb 'GET 157 | > type Post = Verb 'POST 158 | > type Put = Verb 'PUT 159 | 160 | > type DogAPI = "dog" :> Get '[JSON] Value 161 | > type CatAPI = "cat" :> Get '[JSON] Value 162 | > type PetAPI = "api" :> DogAPI :<|> CatAPI 163 | 164 | > -- # Type families (aka. functions at the type-level) 165 | 166 | -- Type level-functions, similar to value level functions 167 | -- See singletons. Package for re-implementing the Prelude. 168 | 169 | -- Is a list null? 170 | 171 | > nul :: [a] -> Bool 172 | > nul [] = True 173 | > nul (_:_) = False 174 | 175 | -- | Is a type-level list nul? 176 | -- https://www.seas.upenn.edu/~sweirich/papers/haskell12.pdf 177 | -- Richard Eisenberg, spearheading dependent types in GHC Haskell 178 | -- Wrote singletons, admits its a "hack". 179 | 180 | -- | Nul is a 'closed' type family, which means it cannot be extended 181 | -- Open type families exist, which allow you to make new instances across modules. 182 | -- Haskell stripe library uses this to implement conditional parameters 183 | 184 | > type family Nul (xs :: [k]) :: Bool where 185 | > Nul '[] = 'True 186 | > Nul (x ': xs) = 'False 187 | 188 | -- | Type-level concat function 189 | 190 | > type family a ++ b :: [k] where 191 | > a ++ '[] = a 192 | > '[] ++ b = b 193 | > (x ': xs) ++ b = x ': xs ++ b 194 | 195 | -- | Example Web API 196 | 197 | > type API = "api" :> "foo" :> Get '[JSON] Bool 198 | > :<|> "api" :> "lol" :> Get '[JSON] Bool 199 | 200 | -- | Type function for extracting path fragments from our servant grammar 201 | 202 | > type family Segments (xs :: k) :: [Symbol] where 203 | > Segments (Verb a b c) = '[] 204 | > Segments (left :<|> right) = Segments left ++ Segments right 205 | > Segments (sym :> b) = sym ': Segments b 206 | 207 | -- | Exercise: Extract segments from API 208 | -- λ> :kind! Segments API 209 | -- Segments API :: [Symbol] 210 | -- = '["api", "foo", "api", "lol"] 211 | 212 | -- | Example of typeclass "induction" 213 | -- Where base case is specified, along with the recursive-step. 214 | 215 | > class ReifySymbols (xs :: [Symbol]) where 216 | > reifySymbols :: Proxy xs -> [String] 217 | 218 | -- | Base case (similar to how base case is written in most haskell functions (see nul above) 219 | 220 | > instance ReifySymbols '[] where 221 | > reifySymbols Proxy = [] 222 | 223 | -- | Recursive step, pop-off some information from the type-level, recurse one step closer to the base case 224 | 225 | > instance (ReifySymbols xs, KnownSymbol sym) => ReifySymbols (sym ': xs) where 226 | > reifySymbols Proxy = symbolVal (Proxy @ sym) : reifySymbols (Proxy @ xs) 227 | 228 | > -- symbolVal (Proxy @ sym) : symbolVal (Proxy @ sym) : symbolVal (Proxy @ sym) : [] 229 | > -- "foo" : "bar" : "quuz" : [] 230 | > -- ["foo","bar","quuz"] 231 | 232 | -- | Apply type level function, reify resultant type as value 233 | -- In this case fetch all the path fragments as values. 234 | 235 | > segmentsAsValues :: [String] 236 | > segmentsAsValues = reifySymbols (Proxy @ (Segments API)) 237 | 238 | -- | GHC.Generics 239 | -- Andres Loh, author of generics-sop, helped pioneer Generics in GHC. 240 | -- https://www.andres-loeh.de/ExploringGH.pdf 241 | 242 | > data Person = Person 243 | > { name :: String 244 | > , age :: Int 245 | > } deriving stock (Show, Eq, Generic) 246 | > deriving anyclass (ToJSON) 247 | 248 | -- | Show :kind! Person 249 | -- recordFields :: Generic a => a -> [String] 250 | 251 | > type family RecordFields (xs :: k) :: [Symbol] where 252 | > RecordFields (a :*: b) = RecordFields a ++ RecordFields b 253 | > RecordFields (a :+: b) = RecordFields a ++ RecordFields b 254 | > RecordFields (S1 ('MetaSel ('Just s) _ _ _) _) = '[s] 255 | > RecordFields (M1 i c p) = RecordFields p 256 | 257 | > personFields :: [String] 258 | > personFields = reifySymbols (Proxy @ (RecordFields (Rep Person))) 259 | 260 | -- λ> personFields 261 | -- ["name","age"] 262 | 263 | -- Interpret the types as values. 264 | -- Spiritual equivalent of GHC.Generics 265 | -- Combine both of the tools above (type families and type classes) 266 | -- to interpret our grammar as an Http client. 267 | 268 | > data Req 269 | > = Req 270 | > { path :: [String] 271 | > , verb :: Method 272 | > , contentType :: String 273 | > , reqBody :: Maybe BL8.ByteString 274 | > , qParams :: [(String, Maybe String)] 275 | > } deriving (Show, Eq) 276 | > 277 | > data Scheme = HTTP | HTTPS 278 | > deriving (Show, Eq) 279 | > 280 | > data BaseUrl 281 | > = BaseUrl 282 | > { baseUrl :: String 283 | > , basePort :: Int 284 | > , baseScheme :: Scheme 285 | > } deriving (Show, Eq) 286 | > 287 | > defReq :: Req 288 | > defReq = Req mempty GET "*/*" Nothing [] 289 | 290 | -- | This class allows us to reify types as values 291 | -- Embedding a type family in the class is how we 292 | -- can perform a form of type-safe code-generation 293 | 294 | > class HasClient api where 295 | > type ToClient api 296 | > -- ^ Called an associated type family, means this type family is associated to this class 297 | > -- We had previously mentioned closed-type families, at compile-time GHC lifts associated type families out of the scope of the class, so really there are only two version of type families. 298 | > 299 | > client :: Proxy api -> BaseUrl -> ToClient api 300 | > client p b = clientWith p b defReq 301 | > -- ^ client is defined in terms of clientWith 302 | > 303 | > clientWith :: Proxy api -> BaseUrl -> Req -> ToClient api 304 | > -- ^ have to implement this 305 | > 306 | > -- "foo" :> ... 307 | > instance (KnownSymbol sym, HasClient api) => HasClient (sym :> api) where 308 | > type ToClient (sym :> api) = ToClient api 309 | > clientWith Proxy b req = 310 | > clientWith (Proxy @ api) b req { path = path req ++ [nextPath] } 311 | > where 312 | > nextPath :: String 313 | > nextPath = symbolVal (Proxy @ sym) 314 | > 315 | > instance (Show a, KnownSymbol sym, HasClient api) => HasClient (Capture sym a :> api) where 316 | > type ToClient (Capture sym a :> api) = a -> ToClient api 317 | > clientWith Proxy b req x = 318 | > clientWith (Proxy @ api) b req { 319 | > path = path req ++ [show x] 320 | > } 321 | > 322 | > instance (KnownSymbol sym, HasClient api) => HasClient (QueryParam sym String :> api) where 323 | > type ToClient (QueryParam sym String :> api) = Maybe String -> ToClient api 324 | > clientWith Proxy b req mb = 325 | > clientWith (Proxy @ api) b req { 326 | > qParams = (k, mb) : qParams req 327 | > } where 328 | > k = symbolVal (Proxy @ sym) 329 | > 330 | > instance (ToJSON a, HasClient api) => HasClient (ReqBody '[JSON] a :> api) where 331 | > type ToClient (ReqBody '[JSON] a :> api) = a -> ToClient api 332 | > clientWith Proxy b req x = 333 | > clientWith (Proxy @ api) b req { 334 | > reqBody = Just (encode x) 335 | > } 336 | > 337 | > instance (HasClient l, HasClient r) => HasClient (l :<|> r) where 338 | > type ToClient (l :<|> r) = ToClient l :<|> ToClient r 339 | > clientWith Proxy b req = 340 | > clientWith (Proxy @ l) b req :<|> 341 | > clientWith (Proxy @ r) b req 342 | 343 | -- | Acts as a way to lower type-level terms to value level terms. 344 | -- DataKinds allows us to promote Haskell values as types 345 | -- DataKinds allows us to promote Haskell types as Kinds 346 | -- We can go up, but can we come back down? 347 | -- Yes, but we have to write that logic oursleves 348 | -- Example of type-level "Demotion" 349 | 350 | > class ToMethod (m :: Method) where 351 | > toMethod :: Proxy m -> Method 352 | 353 | > instance ToMethod 'GET where toMethod Proxy = GET 354 | > instance ToMethod 'POST where toMethod Proxy = POST 355 | > 356 | > debug :: Bool 357 | > debug = True 358 | > 359 | > instance (ToMethod method, FromJSON a) => HasClient (Verb method '[JSON] a) where 360 | > type ToClient (Verb method '[JSON] a) = IO (Either Error a) 361 | > clientWith Proxy BaseUrl {..} Req {..} = do 362 | > initReq <- parseRequest url 363 | > let request = 364 | > initReq 365 | > { method = B8.pack $ show $ toMethod (Proxy @ method) 366 | > , requestBody = maybe (requestBody initReq) RequestBodyLBS reqBody 367 | > , queryString = B8.pack $ 368 | > [ '?' | not (null qParams) ] <> intercalate "&" 369 | > [ k <> "=" <> v 370 | > | (k, Just v) <- qParams 371 | > ] 372 | > , secure = baseScheme == HTTPS 373 | > , requestHeaders = requestHeaders initReq <> 374 | > [ ("Content-Type", "application/json") ] 375 | > } 376 | > when debug (print request) 377 | > manager <- getGlobalManager 378 | > response <- httpLbs request manager 379 | > let body = responseBody response 380 | > case statusCode (responseStatus response) of 381 | > x | x > 400 && x < 500 -> 382 | > pure 383 | > $ Left 384 | > $ RequestError x body 385 | > | x >= 500 -> 386 | > pure 387 | > $ Left 388 | > $ ServerError x body 389 | > | otherwise -> 390 | > case eitherDecode @a body of 391 | > Left e -> do 392 | > print body 393 | > pure $ Left (DecodeFailure x e) 394 | > Right r -> pure (Right r) 395 | > where 396 | > url = 397 | > mconcat 398 | > [ if baseScheme == HTTP 399 | > then "http://" 400 | > else "https://" 401 | > , baseUrl 402 | > , ":" 403 | > , show basePort 404 | > , "/" 405 | > , intercalate "/" path 406 | > ] 407 | > data Error 408 | > = ServerError Int BL8.ByteString 409 | > | RequestError Int BL8.ByteString 410 | > | DecodeFailure Int String 411 | > | ConnFailure String 412 | > deriving (Show, Eq) 413 | 414 | > -- # Bringing it all together 415 | 416 | > type GetAPI = 417 | > "get" 418 | > :> QueryParam "foo" String 419 | > :> QueryParam "bar" String 420 | > :> QueryParam "quuz" String 421 | > :> Get '[JSON] Value 422 | > 423 | > bob, alice :: Person 424 | > bob = Person "Bob" 55 425 | > alice = Person "Alice" 55 426 | > 427 | > type PostAPI = 428 | > "post" 429 | > :> ReqBody '[JSON] Person 430 | > :> Post '[JSON] Value 431 | > 432 | > type FullAPI = GetAPI :<|> PostAPI 433 | > 434 | > submit :: IO (Either Error Value) -> IO () 435 | > submit f = f >>= \case 436 | > Left e -> 437 | > print e 438 | > Right r -> 439 | > BL8.putStrLn (encodePretty r) 440 | > 441 | > postEcho :: Person -> IO (Either Error Value) 442 | > getEcho :: Maybe String -> Maybe String -> Maybe String -> IO (Either Error Value) 443 | 444 | -- | Types defined above, this is made possible via the type-family in HasClient 445 | -- > type ToClient (l :<|> r) = ToClient l :<|> ToClient r 446 | 447 | > getEcho :<|> postEcho = client (Proxy @ FullAPI) postmanEcho 448 | 449 | > postmanEcho :: BaseUrl 450 | > postmanEcho = BaseUrl "postman-echo.com" 443 HTTPS 451 | 452 | -- Summary 453 | 454 | -- In this talk we discussed how an embedded domain specific language is a special purpose 455 | -- limited language with terms that are used to describe a particular domain, along with a way to interpret this language into objects that suit the domain. Servant is one such domain specific language for web programming. We discussed how servant is similar in spirit to GHC.Generics, where GHC.Generics can be thought of as a domain specific language for reifying objects from Haskell records. We showed how we can use the same type-level induction and reification techniques to extract information from a Haskell record's metadata at compile time. We discussed various type-level extensions like PolyKinds, DataKinds, TypeOperators (all of which servant would not be possible without). We overviewied type level symbols and naturals that are enabled via the DataKinds extension. We showed the inner workings of a real servant interpretation for a subset of the servant grammar that actually works on a real world API. After this talk you should be more equipped to deal with type level programming in GHC and be an informed user of the Haskell servant library. 456 | 457 | -- Bonus section: 458 | -- **Servant-server from Scratch** 459 | 460 | > type family Server a 461 | > type instance Server (l :<|> r) = Server l :<|> Server r 462 | > type instance Server (Get _ a) = IO a 463 | > type instance Server ((s :: Symbol) :> r) = Server r 464 | > type instance Server (Capture s a :> r) = a -> Server r 465 | > 466 | > class HasServer a where 467 | > route 468 | > :: Proxy a 469 | > -> Server a 470 | > -> [T.Text] 471 | > -> Network.Wai.Request 472 | > -> (Response -> IO ResponseReceived) 473 | > -> Maybe (IO ResponseReceived) 474 | > 475 | > type SomeAPI = 476 | > "api" :> Capture "hey" Int :> Get '[JSON] String 477 | > :<|> 478 | > "api" :> "ok" :> Capture "hey" String :> Get '[JSON] Int 479 | > 480 | > runServer :: IO () 481 | > runServer = do 482 | > putStrLn "Running on 3000..." 483 | > run 3000 $ serve (Proxy @ SomeAPI) handlers 484 | > where 485 | > handlers = handler :<|> handler2 486 | > handler x = print x >> pure "hey" 487 | > handler2 x = print x >> pure 44 488 | > 489 | > serve 490 | > :: HasServer a 491 | > => Proxy a 492 | > -> Server a 493 | > -> Application 494 | > serve proxy handlers = \req resp -> do 495 | > case route proxy handlers (paths req) req resp of 496 | > Nothing -> resp $ responseLBS status404 mempty "400" 497 | > Just x -> x 498 | > where 499 | > paths req 500 | > = filter (not . T.null) 501 | > $ T.splitOn "/" 502 | > $ T.decodeUtf8 (rawPathInfo req) 503 | > 504 | > instance (HasServer l, HasServer r) => HasServer (l :<|> r) where 505 | > route Proxy (l :<|> r) path req resp = do 506 | > route (Proxy @ l) l path req resp <|> 507 | > route (Proxy @ r) r path req resp 508 | > 509 | > instance (FromHttpApiData t, HasServer r) => HasServer (Capture name t :> r) where 510 | > route Proxy appath (l:ls) req resp = 511 | > case parseUrlPiece l :: Either Text t of 512 | > Left _ -> 513 | > Nothing 514 | > Right r -> 515 | > route (Proxy @ r) (appath r) ls req resp 516 | > route _ _ _ _ _ = Nothing 517 | > 518 | > instance (KnownSymbol s, HasServer r) => HasServer (s :> r) where 519 | > route Proxy apppath (l:ls) req resp = 520 | > if T.pack (symbolVal (Proxy @ s)) == l 521 | > then route (Proxy @ r) apppath ls req resp 522 | > else Nothing 523 | > route _ _ _ _ _ = Nothing 524 | > 525 | > instance ToJSON a => HasServer (Get xs a) where 526 | > route Proxy s [] _ resp = do 527 | > Just $ s >>= \a -> 528 | > resp $ responseLBS status200 [] (encode a) 529 | > route _ _ _ _ _ = Nothing 530 | > 531 | --------------------------------------------------------------------------------