Remove servant-examples (again)
This commit is contained in:
Julian K. Arni
Sönke Hahn
parent
4e90308b85
commit
79029089db
14 changed files with 0 additions and 990 deletions
|
|
@ -1,124 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
|
||||||
import Data.Aeson hiding ((.:))
|
|
||||||
import Data.ByteString (ByteString)
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Map (Map, fromList)
|
|
||||||
import qualified Data.Map as Map
|
|
||||||
import Data.Text (Text)
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import Servant
|
|
||||||
import Servant.Server.Experimental.Auth
|
|
||||||
|
|
||||||
-- | This file contains an authenticated server using servant's generalized
|
|
||||||
-- authentication support. Our basic authentication scheme is trivial: we
|
|
||||||
-- look for a cookie named "servant-auth-cookie" and its value will contain
|
|
||||||
-- a key, which we use to lookup a User. Obviously this is an absurd example,
|
|
||||||
-- but we pick something simple and non-standard to show you how to extend
|
|
||||||
-- servant's support for authentication.
|
|
||||||
|
|
||||||
-- | A user type that we "fetch from the database" after
|
|
||||||
-- performing authentication
|
|
||||||
newtype User = User { unUser :: Text }
|
|
||||||
|
|
||||||
-- | A (pure) database mapping keys to users.
|
|
||||||
database :: Map ByteString User
|
|
||||||
database = fromList [ ("key1", User "Anne Briggs")
|
|
||||||
, ("key2", User "Bruce Cockburn")
|
|
||||||
, ("key3", User "Ghédalia Tazartès")
|
|
||||||
]
|
|
||||||
|
|
||||||
-- | A method that, when given a password, will return a User.
|
|
||||||
-- This is our bespoke (and bad) authentication logic.
|
|
||||||
lookupUser :: ByteString -> ExceptT ServantErr IO User
|
|
||||||
lookupUser key = case Map.lookup key database of
|
|
||||||
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
|
|
||||||
Just usr -> return usr
|
|
||||||
|
|
||||||
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
|
|
||||||
-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
|
|
||||||
authHandler :: AuthHandler Request User
|
|
||||||
authHandler =
|
|
||||||
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
|
|
||||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
|
||||||
Just authCookieKey -> lookupUser authCookieKey
|
|
||||||
in mkAuthHandler handler
|
|
||||||
|
|
||||||
-- | Data types that will be returned from various api endpoints
|
|
||||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PrivateData
|
|
||||||
|
|
||||||
newtype PublicData = PublicData { somedata :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PublicData
|
|
||||||
|
|
||||||
-- | Our private API that we want to be auth-protected.
|
|
||||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
|
||||||
|
|
||||||
-- | Our public API that doesn't have any protection
|
|
||||||
type PublicAPI = Get '[JSON] [PublicData]
|
|
||||||
|
|
||||||
-- | Our API, with auth-protection
|
|
||||||
type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
|
|
||||||
:<|> "public" :> PublicAPI
|
|
||||||
|
|
||||||
-- | A value holding our type-level API
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
-- | We need to specify the data returned after authentication
|
|
||||||
type instance AuthServerData (AuthProtect "cookie-auth") = User
|
|
||||||
|
|
||||||
-- | The context that will be made available to request handlers. We supply the
|
|
||||||
-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
|
|
||||||
-- of 'AuthProtect' can extract the handler and run it on the request.
|
|
||||||
serverContext :: Context (AuthHandler Request User ': '[])
|
|
||||||
serverContext = authHandler :. EmptyContext
|
|
||||||
|
|
||||||
-- | Our API, where we provide all the author-supplied handlers for each end
|
|
||||||
-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
|
|
||||||
-- argument. We dont' worry about the authentication instrumentation here,
|
|
||||||
-- that is taken care of by supplying context
|
|
||||||
server :: Server API
|
|
||||||
server = privateDataFunc :<|> return publicData
|
|
||||||
|
|
||||||
where privateDataFunc (User name) =
|
|
||||||
return [PrivateData ("this is a secret: " <> name)]
|
|
||||||
publicData = [PublicData "this is a public piece of data"]
|
|
||||||
|
|
||||||
-- | run our server
|
|
||||||
main :: IO ()
|
|
||||||
main = run 8080 (serveWithContext api serverContext server)
|
|
||||||
|
|
||||||
{- Sample Session:
|
|
||||||
|
|
||||||
$ curl -XGET localhost:8080/private
|
|
||||||
Missing auth header
|
|
||||||
>>>>>>> modify auth-combinator example for gen auth
|
|
||||||
>>>>>>> 8246c1f... modify auth-combinator example for gen auth
|
|
||||||
|
|
||||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
|
|
||||||
[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
|
|
||||||
|
|
||||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
|
|
||||||
Invalid Cookie
|
|
||||||
|
|
||||||
$ curl -XGET localhost:8080/public
|
|
||||||
[{"somedata":"this is a public piece of data"}]
|
|
||||||
-}
|
|
||||||
|
|
||||||
|
|
@ -1,105 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
|
|
||||||
module Main where
|
|
||||||
|
|
||||||
import Data.Aeson (ToJSON)
|
|
||||||
import Data.Proxy (Proxy (Proxy))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import Network.Wai.Handler.Warp (run)
|
|
||||||
import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
|
|
||||||
Get, JSON)
|
|
||||||
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
|
|
||||||
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
|
|
||||||
BasicAuthResult( Authorized
|
|
||||||
, Unauthorized
|
|
||||||
),
|
|
||||||
Context ((:.), EmptyContext), Server,
|
|
||||||
serveWithContext)
|
|
||||||
|
|
||||||
-- | let's define some types that our API returns.
|
|
||||||
|
|
||||||
-- | private data that needs protection
|
|
||||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PrivateData
|
|
||||||
|
|
||||||
-- | public data that anyone can use.
|
|
||||||
newtype PublicData = PublicData { somedata :: Text }
|
|
||||||
deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON PublicData
|
|
||||||
|
|
||||||
-- | A user we'll grab from the database when we authenticate someone
|
|
||||||
newtype User = User { userName :: Text }
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | a type to wrap our public api
|
|
||||||
type PublicAPI = Get '[JSON] [PublicData]
|
|
||||||
|
|
||||||
-- | a type to wrap our private api
|
|
||||||
type PrivateAPI = Get '[JSON] PrivateData
|
|
||||||
|
|
||||||
-- | our API
|
|
||||||
type API = "public" :> PublicAPI
|
|
||||||
:<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI
|
|
||||||
|
|
||||||
-- | a value holding a proxy of our API type
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
|
|
||||||
authCheck :: BasicAuthCheck User
|
|
||||||
authCheck =
|
|
||||||
let check (BasicAuthData username password) =
|
|
||||||
if username == "servant" && password == "server"
|
|
||||||
then return (Authorized (User "servant"))
|
|
||||||
else return Unauthorized
|
|
||||||
in BasicAuthCheck check
|
|
||||||
|
|
||||||
-- | We need to supply our handlers with the right Context. In this case,
|
|
||||||
-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
|
|
||||||
-- tagged with "foo-tag" This context is then supplied to 'server' and threaded
|
|
||||||
-- to the BasicAuth HasServer handlers.
|
|
||||||
serverContext :: Context (BasicAuthCheck User ': '[])
|
|
||||||
serverContext = authCheck :. EmptyContext
|
|
||||||
|
|
||||||
-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
|
|
||||||
-- In particular, for the BasicAuth protected handler, we need to supply a function
|
|
||||||
-- that takes 'User' as an argument.
|
|
||||||
server :: Server API
|
|
||||||
server =
|
|
||||||
let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
|
|
||||||
privateAPIHandler (user :: User) = return (PrivateData (userName user))
|
|
||||||
in publicAPIHandler :<|> privateAPIHandler
|
|
||||||
|
|
||||||
-- | hello, server!
|
|
||||||
main :: IO ()
|
|
||||||
main = run 8080 (serveWithContext api serverContext server)
|
|
||||||
|
|
||||||
{- Sample session
|
|
||||||
|
|
||||||
$ curl -XGET localhost:8080/public
|
|
||||||
[{"somedata":"foo"},{"somedata":"bar"}
|
|
||||||
|
|
||||||
$ curl -iXGET localhost:8080/private
|
|
||||||
HTTP/1.1 401 Unauthorized
|
|
||||||
transfer-encoding: chunked
|
|
||||||
Date: Thu, 07 Jan 2016 22:36:38 GMT
|
|
||||||
Server: Warp/3.1.8
|
|
||||||
WWW-Authenticate: Basic realm="foo-realm"
|
|
||||||
|
|
||||||
$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="
|
|
||||||
HTTP/1.1 200 OK
|
|
||||||
transfer-encoding: chunked
|
|
||||||
Date: Thu, 07 Jan 2016 22:37:58 GMT
|
|
||||||
Server: Warp/3.1.8
|
|
||||||
Content-Type: application/json
|
|
||||||
|
|
||||||
{"ssshhh":"servant"}
|
|
||||||
-}
|
|
||||||
|
|
@ -1,148 +0,0 @@
|
||||||
name: servant-examples
|
|
||||||
version: 0.5
|
|
||||||
synopsis: Example programs for servant
|
|
||||||
description: Example programs for servant,
|
|
||||||
showcasing solutions to common needs.
|
|
||||||
homepage: http://haskell-servant.github.io/
|
|
||||||
license: BSD3
|
|
||||||
license-file: LICENSE
|
|
||||||
author: Servant Contributors
|
|
||||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
|
||||||
copyright: 2015-2016 Servant Contributors
|
|
||||||
category: Web
|
|
||||||
build-type: Simple
|
|
||||||
cabal-version: >=1.10
|
|
||||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: http://github.com/haskell-servant/servant.git
|
|
||||||
|
|
||||||
executable tutorial
|
|
||||||
main-is: tutorial.hs
|
|
||||||
other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-imports
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, directory
|
|
||||||
, http-types
|
|
||||||
, js-jquery
|
|
||||||
, lucid
|
|
||||||
, random
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-docs == 0.5.*
|
|
||||||
, servant-js == 0.5.*
|
|
||||||
, servant-lucid == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, time
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: tutorial
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable t8-main
|
|
||||||
main-is: t8-main.hs
|
|
||||||
other-modules: T3, T8
|
|
||||||
hs-source-dirs: tutorial
|
|
||||||
default-language: Haskell2010
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
build-depends:
|
|
||||||
aeson
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, http-client > 0.4 && < 0.5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-client == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
, wai
|
|
||||||
|
|
||||||
executable hackage
|
|
||||||
main-is: hackage.hs
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >=4.7 && < 5
|
|
||||||
, http-client > 0.4 && < 0.5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-client == 0.5.*
|
|
||||||
, text
|
|
||||||
, transformers
|
|
||||||
, transformers-compat
|
|
||||||
hs-source-dirs: hackage
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable wai-middleware
|
|
||||||
main-is: wai-middleware.hs
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, wai-extra
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: wai-middleware
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable basic-auth
|
|
||||||
main-is: basic-auth.hs
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, http-types
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: basic-auth
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable auth-combinator
|
|
||||||
main-is: auth-combinator.hs
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, containers
|
|
||||||
, http-types
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, text
|
|
||||||
, transformers
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
hs-source-dirs: auth-combinator
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable socket-io-chat
|
|
||||||
main-is: socket-io-chat.hs
|
|
||||||
ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
|
|
||||||
other-modules: Chat
|
|
||||||
build-depends:
|
|
||||||
aeson >= 0.8
|
|
||||||
, base >= 4.7 && < 5
|
|
||||||
, bytestring
|
|
||||||
, http-types
|
|
||||||
, servant == 0.5.*
|
|
||||||
, servant-server == 0.5.*
|
|
||||||
, socket-io
|
|
||||||
, engine-io
|
|
||||||
, engine-io-wai
|
|
||||||
, text
|
|
||||||
, wai
|
|
||||||
, warp
|
|
||||||
, transformers
|
|
||||||
, stm
|
|
||||||
, mtl
|
|
||||||
ghc-options: -Wall -O2 -threaded
|
|
||||||
hs-source-dirs: socket-io-chat
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
@ -1,54 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
|
|
||||||
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
#if !MIN_VERSION_base(4,8,0)
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
#endif
|
|
||||||
import Network.EngineIO.Wai
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp (run)
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
|
|
||||||
import qualified Control.Concurrent.STM as STM
|
|
||||||
import qualified Network.SocketIO as SocketIO
|
|
||||||
|
|
||||||
|
|
||||||
import Chat (ServerState (..), eioServer)
|
|
||||||
|
|
||||||
|
|
||||||
type API = "socket.io" :> Raw
|
|
||||||
:<|> Raw
|
|
||||||
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
|
|
||||||
server :: WaiMonad () -> Server API
|
|
||||||
server sHandler = socketIOHandler
|
|
||||||
:<|> serveDirectory "socket-io-chat/resources"
|
|
||||||
|
|
||||||
where
|
|
||||||
socketIOHandler req respond = toWaiApplication sHandler req respond
|
|
||||||
|
|
||||||
|
|
||||||
app :: WaiMonad () -> Application
|
|
||||||
app sHandler = serve api $ server sHandler
|
|
||||||
|
|
||||||
port :: Int
|
|
||||||
port = 3001
|
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
state <- ServerState <$> STM.newTVarIO 0
|
|
||||||
sHandler <- SocketIO.initialize waiAPI (eioServer state)
|
|
||||||
putStrLn $ "Running on " <> show port
|
|
||||||
run port $ app sHandler
|
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -1,45 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T1 where
|
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Time.Calendar
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
data User = User
|
|
||||||
{ name :: String
|
|
||||||
, age :: Int
|
|
||||||
, email :: String
|
|
||||||
, registration_date :: Day
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
#if !MIN_VERSION_aeson(0,10,0)
|
|
||||||
-- orphan ToJSON instance for Day. necessary to derive one for User
|
|
||||||
instance ToJSON Day where
|
|
||||||
-- display a day in YYYY-mm-dd format
|
|
||||||
toJSON d = toJSON (showGregorian d)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
instance ToJSON User
|
|
||||||
|
|
||||||
type UserAPI = "users" :> Get '[JSON] [User]
|
|
||||||
|
|
||||||
users :: [User]
|
|
||||||
users =
|
|
||||||
[ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
|
|
||||||
, User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
|
|
||||||
]
|
|
||||||
|
|
||||||
userAPI :: Proxy UserAPI
|
|
||||||
userAPI = Proxy
|
|
||||||
|
|
||||||
server :: Server UserAPI
|
|
||||||
server = return users
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve userAPI server
|
|
||||||
|
|
@ -1,71 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T10 where
|
|
||||||
|
|
||||||
import Data.ByteString.Lazy (ByteString)
|
|
||||||
import Data.Text.Lazy (pack)
|
|
||||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
|
||||||
import Network.HTTP.Types
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
import Servant.Docs
|
|
||||||
import qualified T3
|
|
||||||
|
|
||||||
type DocsAPI = T3.API :<|> Raw
|
|
||||||
|
|
||||||
instance ToCapture (Capture "x" Int) where
|
|
||||||
toCapture _ = DocCapture "x" "(integer) position on the x axis"
|
|
||||||
|
|
||||||
instance ToCapture (Capture "y" Int) where
|
|
||||||
toCapture _ = DocCapture "y" "(integer) position on the y axis"
|
|
||||||
|
|
||||||
instance ToSample T3.Position where
|
|
||||||
toSamples _ = singleSample (T3.Position 3 14)
|
|
||||||
|
|
||||||
instance ToParam (QueryParam "name" String) where
|
|
||||||
toParam _ =
|
|
||||||
DocQueryParam "name"
|
|
||||||
["Alp", "John Doe", "..."]
|
|
||||||
"Name of the person to say hello to."
|
|
||||||
Normal
|
|
||||||
|
|
||||||
instance ToSample T3.HelloMessage where
|
|
||||||
toSamples _ =
|
|
||||||
[ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp")
|
|
||||||
, ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward")
|
|
||||||
]
|
|
||||||
|
|
||||||
ci :: T3.ClientInfo
|
|
||||||
ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
|
|
||||||
|
|
||||||
instance ToSample T3.ClientInfo where
|
|
||||||
toSamples _ = singleSample ci
|
|
||||||
|
|
||||||
instance ToSample T3.Email where
|
|
||||||
toSamples _ = singleSample (T3.emailForClient ci)
|
|
||||||
|
|
||||||
api :: Proxy DocsAPI
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
docsBS :: ByteString
|
|
||||||
docsBS = encodeUtf8
|
|
||||||
. pack
|
|
||||||
. markdown
|
|
||||||
$ docsWithIntros [intro] T3.api
|
|
||||||
|
|
||||||
where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"]
|
|
||||||
|
|
||||||
server :: Server DocsAPI
|
|
||||||
server = T3.server :<|> serveDocs
|
|
||||||
|
|
||||||
where serveDocs _ respond =
|
|
||||||
respond $ responseLBS ok200 [plain] docsBS
|
|
||||||
|
|
||||||
plain = ("Content-Type", "text/plain")
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve api server
|
|
||||||
|
|
@ -1,52 +0,0 @@
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T2 where
|
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Time.Calendar
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
data User = User
|
|
||||||
{ name :: String
|
|
||||||
, age :: Int
|
|
||||||
, email :: String
|
|
||||||
, registration_date :: Day
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
#if !MIN_VERSION_aeson(0,10,0)
|
|
||||||
-- orphan ToJSON instance for Day. necessary to derive one for User
|
|
||||||
instance ToJSON Day where
|
|
||||||
-- display a day in YYYY-mm-dd format
|
|
||||||
toJSON d = toJSON (showGregorian d)
|
|
||||||
#endif
|
|
||||||
|
|
||||||
instance ToJSON User
|
|
||||||
|
|
||||||
type UserAPI = "users" :> Get '[JSON] [User]
|
|
||||||
:<|> "albert" :> Get '[JSON] User
|
|
||||||
:<|> "isaac" :> Get '[JSON] User
|
|
||||||
|
|
||||||
isaac :: User
|
|
||||||
isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
|
|
||||||
|
|
||||||
albert :: User
|
|
||||||
albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
|
|
||||||
|
|
||||||
users :: [User]
|
|
||||||
users = [isaac, albert]
|
|
||||||
|
|
||||||
userAPI :: Proxy UserAPI
|
|
||||||
userAPI = Proxy
|
|
||||||
|
|
||||||
server :: Server UserAPI
|
|
||||||
server = return users
|
|
||||||
:<|> return albert
|
|
||||||
:<|> return isaac
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve userAPI server
|
|
||||||
|
|
@ -1,84 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T3 where
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.List
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
data Position = Position
|
|
||||||
{ x :: Int
|
|
||||||
, y :: Int
|
|
||||||
} deriving (Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON Position
|
|
||||||
instance ToJSON Position
|
|
||||||
|
|
||||||
newtype HelloMessage = HelloMessage { msg :: String }
|
|
||||||
deriving (Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON HelloMessage
|
|
||||||
instance ToJSON HelloMessage
|
|
||||||
|
|
||||||
data ClientInfo = ClientInfo
|
|
||||||
{ name :: String
|
|
||||||
, email :: String
|
|
||||||
, age :: Int
|
|
||||||
, interested_in :: [String]
|
|
||||||
} deriving (Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON ClientInfo
|
|
||||||
instance ToJSON ClientInfo
|
|
||||||
|
|
||||||
data Email = Email
|
|
||||||
{ from :: String
|
|
||||||
, to :: String
|
|
||||||
, subject :: String
|
|
||||||
, body :: String
|
|
||||||
} deriving (Show, Generic)
|
|
||||||
|
|
||||||
instance FromJSON Email
|
|
||||||
instance ToJSON Email
|
|
||||||
|
|
||||||
emailForClient :: ClientInfo -> Email
|
|
||||||
emailForClient c = Email from' to' subject' body'
|
|
||||||
|
|
||||||
where from' = "great@company.com"
|
|
||||||
to' = email c
|
|
||||||
subject' = "Hey " ++ name c ++ ", we miss you!"
|
|
||||||
body' = "Hi " ++ name c ++ ",\n\n"
|
|
||||||
++ "Since you've recently turned " ++ show (age c)
|
|
||||||
++ ", have you checked out our latest "
|
|
||||||
++ intercalate ", " (interested_in c)
|
|
||||||
++ " products? Give us a visit!"
|
|
||||||
|
|
||||||
type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
|
|
||||||
:<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
|
|
||||||
:<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
server :: Server API
|
|
||||||
server = position
|
|
||||||
:<|> hello
|
|
||||||
:<|> marketing
|
|
||||||
|
|
||||||
where position :: Int -> Int -> ExceptT ServantErr IO Position
|
|
||||||
position x y = return (Position x y)
|
|
||||||
|
|
||||||
hello :: Maybe String -> ExceptT ServantErr IO HelloMessage
|
|
||||||
hello mname = return . HelloMessage $ case mname of
|
|
||||||
Nothing -> "Hello, anonymous coward"
|
|
||||||
Just n -> "Hello, " ++ n
|
|
||||||
|
|
||||||
marketing :: ClientInfo -> ExceptT ServantErr IO Email
|
|
||||||
marketing clientinfo = return (emailForClient clientinfo)
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve api server
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T4 where
|
|
||||||
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Foldable (foldMap)
|
|
||||||
import GHC.Generics
|
|
||||||
import Lucid
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
import Servant.HTML.Lucid
|
|
||||||
|
|
||||||
data Person = Person
|
|
||||||
{ firstName :: String
|
|
||||||
, lastName :: String
|
|
||||||
, age :: Int
|
|
||||||
} deriving Generic -- for the JSON instance
|
|
||||||
|
|
||||||
-- JSON serialization
|
|
||||||
instance ToJSON Person
|
|
||||||
|
|
||||||
-- HTML serialization of a single person
|
|
||||||
instance ToHtml Person where
|
|
||||||
toHtml person =
|
|
||||||
tr_ $ do
|
|
||||||
td_ (toHtml $ firstName person)
|
|
||||||
td_ (toHtml $ lastName person)
|
|
||||||
td_ (toHtml . show $ age person)
|
|
||||||
|
|
||||||
toHtmlRaw = toHtml
|
|
||||||
|
|
||||||
-- HTML serialization of a list of persons
|
|
||||||
instance ToHtml [Person] where
|
|
||||||
toHtml persons = table_ $ do
|
|
||||||
tr_ $ do
|
|
||||||
th_ "first name"
|
|
||||||
th_ "last name"
|
|
||||||
th_ "age"
|
|
||||||
|
|
||||||
foldMap toHtml persons
|
|
||||||
|
|
||||||
toHtmlRaw = toHtml
|
|
||||||
|
|
||||||
persons :: [Person]
|
|
||||||
persons =
|
|
||||||
[ Person "Isaac" "Newton" 372
|
|
||||||
, Person "Albert" "Einstein" 136
|
|
||||||
]
|
|
||||||
|
|
||||||
type PersonAPI = "persons" :> Get '[JSON, HTML] [Person]
|
|
||||||
|
|
||||||
personAPI :: Proxy PersonAPI
|
|
||||||
personAPI = Proxy
|
|
||||||
|
|
||||||
server :: Server PersonAPI
|
|
||||||
server = return persons
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve personAPI server
|
|
||||||
|
|
@ -1,37 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T5 where
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Except
|
|
||||||
import Data.Aeson
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
import System.Directory
|
|
||||||
|
|
||||||
type IOAPI = "myfile.txt" :> Get '[JSON] FileContent
|
|
||||||
|
|
||||||
ioAPI :: Proxy IOAPI
|
|
||||||
ioAPI = Proxy
|
|
||||||
|
|
||||||
newtype FileContent = FileContent
|
|
||||||
{ content :: String }
|
|
||||||
deriving Generic
|
|
||||||
|
|
||||||
instance ToJSON FileContent
|
|
||||||
|
|
||||||
server :: Server IOAPI
|
|
||||||
server = do
|
|
||||||
exists <- liftIO (doesFileExist "myfile.txt")
|
|
||||||
if exists
|
|
||||||
then liftIO (readFile "myfile.txt") >>= return . FileContent
|
|
||||||
else throwE custom404Err
|
|
||||||
|
|
||||||
where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve ioAPI server
|
|
||||||
|
|
@ -1,18 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T6 where
|
|
||||||
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
type API = "code" :> Raw
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
server :: Server API
|
|
||||||
server = serveDirectory "tutorial"
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve api server
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T7 where
|
|
||||||
|
|
||||||
import Control.Monad.Trans.Except
|
|
||||||
import Control.Monad.Trans.Reader
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
type ReaderAPI = "a" :> Get '[JSON] Int
|
|
||||||
:<|> "b" :> Get '[JSON] String
|
|
||||||
|
|
||||||
readerAPI :: Proxy ReaderAPI
|
|
||||||
readerAPI = Proxy
|
|
||||||
|
|
||||||
readerServerT :: ServerT ReaderAPI (Reader String)
|
|
||||||
readerServerT = a :<|> b
|
|
||||||
|
|
||||||
where a :: Reader String Int
|
|
||||||
a = return 1797
|
|
||||||
|
|
||||||
b :: Reader String String
|
|
||||||
b = ask
|
|
||||||
|
|
||||||
readerServer :: Server ReaderAPI
|
|
||||||
readerServer = enter readerToEither readerServerT
|
|
||||||
|
|
||||||
where readerToEither :: Reader String :~> ExceptT ServantErr IO
|
|
||||||
readerToEither = Nat $ \r -> return (runReader r "hi")
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve readerAPI readerServer
|
|
||||||
|
|
@ -1,105 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TypeOperators #-}
|
|
||||||
module T9 where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Text (Text)
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Servant
|
|
||||||
import Servant.JS
|
|
||||||
import System.Random
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import qualified Data.Text.IO as TIO
|
|
||||||
import qualified Language.Javascript.JQuery as JQ
|
|
||||||
|
|
||||||
data Point = Point
|
|
||||||
{ x :: Double
|
|
||||||
, y :: Double
|
|
||||||
} deriving Generic
|
|
||||||
|
|
||||||
instance ToJSON Point
|
|
||||||
|
|
||||||
randomPoint :: MonadIO m => m Point
|
|
||||||
randomPoint = liftIO . getStdRandom $ \g ->
|
|
||||||
let (rx, g') = randomR (-1, 1) g
|
|
||||||
(ry, g'') = randomR (-1, 1) g'
|
|
||||||
in (Point rx ry, g'')
|
|
||||||
|
|
||||||
data Search a = Search
|
|
||||||
{ query :: Text
|
|
||||||
, results :: [a]
|
|
||||||
} deriving Generic
|
|
||||||
|
|
||||||
mkSearch :: Text -> [a] -> Search a
|
|
||||||
mkSearch = Search
|
|
||||||
|
|
||||||
instance ToJSON a => ToJSON (Search a)
|
|
||||||
|
|
||||||
data Book = Book
|
|
||||||
{ author :: Text
|
|
||||||
, title :: Text
|
|
||||||
, year :: Int
|
|
||||||
} deriving Generic
|
|
||||||
|
|
||||||
instance ToJSON Book
|
|
||||||
|
|
||||||
book :: Text -> Text -> Int -> Book
|
|
||||||
book = Book
|
|
||||||
|
|
||||||
books :: [Book]
|
|
||||||
books =
|
|
||||||
[ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000
|
|
||||||
, book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008
|
|
||||||
, book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011
|
|
||||||
, book "Graham Hutton" "Programming in Haskell" 2007
|
|
||||||
, book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013
|
|
||||||
, book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998
|
|
||||||
]
|
|
||||||
|
|
||||||
searchBook :: Monad m => Maybe Text -> m (Search Book)
|
|
||||||
searchBook Nothing = return (mkSearch "" books)
|
|
||||||
searchBook (Just q) = return (mkSearch q books')
|
|
||||||
|
|
||||||
where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b)
|
|
||||||
|| q' `T.isInfixOf` T.toLower (title b)
|
|
||||||
)
|
|
||||||
books
|
|
||||||
q' = T.toLower q
|
|
||||||
|
|
||||||
type API = "point" :> Get '[JSON] Point
|
|
||||||
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
|
|
||||||
|
|
||||||
type API' = API :<|> Raw
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
api' :: Proxy API'
|
|
||||||
api' = Proxy
|
|
||||||
|
|
||||||
server :: Server API
|
|
||||||
server = randomPoint
|
|
||||||
:<|> searchBook
|
|
||||||
|
|
||||||
server' :: Server API'
|
|
||||||
server' = server
|
|
||||||
:<|> serveDirectory "tutorial/t9"
|
|
||||||
|
|
||||||
apiJS :: Text
|
|
||||||
apiJS = jsForAPI api jquery
|
|
||||||
|
|
||||||
writeJSFiles :: IO ()
|
|
||||||
writeJSFiles = do
|
|
||||||
TIO.writeFile "tutorial/t9/api.js" apiJS
|
|
||||||
jq <- TIO.readFile =<< JQ.file
|
|
||||||
TIO.writeFile "tutorial/t9/jq.js" jq
|
|
||||||
|
|
||||||
app :: Application
|
|
||||||
app = serve api' server'
|
|
||||||
|
|
@ -1,51 +0,0 @@
|
||||||
{-# LANGUAGE DataKinds #-}
|
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
import Data.Aeson
|
|
||||||
import Data.Text
|
|
||||||
import GHC.Generics
|
|
||||||
import Network.Wai
|
|
||||||
import Network.Wai.Handler.Warp
|
|
||||||
import Network.Wai.Middleware.RequestLogger
|
|
||||||
import Servant
|
|
||||||
|
|
||||||
data Product = Product
|
|
||||||
{ name :: Text
|
|
||||||
, brand :: Text
|
|
||||||
, current_price_eur :: Double
|
|
||||||
, available :: Bool
|
|
||||||
} deriving (Eq, Show, Generic)
|
|
||||||
|
|
||||||
instance ToJSON Product
|
|
||||||
|
|
||||||
products :: [Product]
|
|
||||||
products = [p1, p2]
|
|
||||||
|
|
||||||
where p1 = Product "Haskell laptop sticker"
|
|
||||||
"GHC Industries"
|
|
||||||
2.50
|
|
||||||
True
|
|
||||||
|
|
||||||
p2 = Product "Foldable USB drive"
|
|
||||||
"Well-Typed"
|
|
||||||
13.99
|
|
||||||
False
|
|
||||||
|
|
||||||
type SimpleAPI = Get '[JSON] [Product]
|
|
||||||
|
|
||||||
simpleAPI :: Proxy SimpleAPI
|
|
||||||
simpleAPI = Proxy
|
|
||||||
|
|
||||||
server :: Server SimpleAPI
|
|
||||||
server = return products
|
|
||||||
|
|
||||||
-- logStdout :: Middleware
|
|
||||||
-- i.e, logStdout :: Application -> Application
|
|
||||||
-- serve :: Proxy api -> Context context -> Server api -> Application
|
|
||||||
-- so applying a middleware is really as simple as
|
|
||||||
-- applying a function to the result of 'serve'
|
|
||||||
app :: Application
|
|
||||||
app = logStdout (serve simpleAPI server)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = run 8080 app
|
|
||||||
Loading…
Add table
Reference in a new issue