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…
Reference in a new issue