Merge pull request #64 from haskell-servant/getting-started-examples

Tutorial examples

servant-examples/servant-examples.cabal

@@ -13,6 +13,45 @@ category:            Web
 build-type:          Simple
 cabal-version:       >=1.10
 
+executable tutorial
+  main-is: tutorial.hs
+  other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10
+  build-depends:
+      aeson >= 0.8
+    , base >= 4.7
+    , bytestring
+    , directory
+    , either
+    , http-types
+    , js-jquery
+    , lucid
+    , random
+    , servant
+    , servant-docs
+    , servant-jquery
+    , servant-lucid
+    , servant-server
+    , text
+    , time
+    , transformers
+    , wai
+    , warp
+  hs-source-dirs: tutorial
+  default-language: Haskell2010
+
+executable t8-main
+  main-is: t8-main.hs
+  hs-source-dirs: tutorial
+  default-language: Haskell2010
+  build-depends:
+      aeson
+    , base
+    , either
+    , servant
+    , servant-client
+    , servant-server
+    , wai
+
 executable hackage
   main-is:             hackage.hs
   build-depends:

servant-examples/tutorial/T1.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# 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)
+
+-- 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)
+
+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

servant-examples/tutorial/T10.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+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 T3.Position where
+  toSample _ = Just (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 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 T3.ClientInfo where
+  toSample _ = Just ci
+
+instance ToSample T3.Email T3.Email where
+  toSample _ = Just (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

servant-examples/tutorial/T2.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# 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)
+
+-- 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)
+
+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

servant-examples/tutorial/T3.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+module T3 where
+
+import Control.Monad.Trans.Either
+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 -> EitherT ServantErr IO Position
+        position x y = return (Position x y)
+
+        hello :: Maybe String -> EitherT ServantErr IO HelloMessage
+        hello mname = return . HelloMessage $ case mname of
+          Nothing -> "Hello, anonymous coward"
+          Just n  -> "Hello, " ++ n
+
+        marketing :: ClientInfo -> EitherT ServantErr IO Email
+        marketing clientinfo = return (emailForClient clientinfo)
+
+app :: Application
+app = serve api server

servant-examples/tutorial/T4.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+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 p =
+    tr_ $ do
+      td_ (toHtml $ firstName p)
+      td_ (toHtml $ lastName p)
+      td_ (toHtml . show $ age p)
+
+  toHtmlRaw = toHtml
+
+-- HTML serialization of a list of persons
+instance ToHtml [Person] where
+  toHtml persons = table_ $ do
+    tr_ $ do
+      td_ "first name"
+      td_ "last name"
+      td_ "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

servant-examples/tutorial/T5.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+module T5 where
+
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
+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 left custom404Err
+
+  where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
+
+app :: Application
+app = serve ioAPI server

servant-examples/tutorial/T6.hs

@@ -0,0 +1,18 @@
+{-# 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

servant-examples/tutorial/T7.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module T7 where
+
+import Control.Monad.Trans.Either
+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 :~> EitherT ServantErr IO
+        readerToEither = Nat $ \r -> return (runReader r "hi")
+
+app :: Application
+app = serve readerAPI readerServer

servant-examples/tutorial/T8.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module T8 where
+
+import Control.Monad.Trans.Either
+import Data.Aeson
+import Servant
+import Servant.Client
+
+import T3
+
+position :: Int -- ^ value for "x"
+         -> Int -- ^ value for "y"
+         -> EitherT ServantError IO Position
+
+hello :: Maybe String -- ^ an optional value for "name"
+      -> EitherT ServantError IO HelloMessage
+
+marketing :: ClientInfo -- ^ value for the request body
+          -> EitherT ServantError IO Email
+
+position :<|> hello :<|> marketing = client api baseUrl
+
+baseUrl :: BaseUrl
+baseUrl = BaseUrl Http "localhost" 8081
+
+queries :: EitherT ServantError IO (Position, HelloMessage, Email)
+queries = do
+  pos <- position 10 10
+  msg <- hello (Just "servant")
+  em  <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
+  return (pos, msg, em)
+
+run :: IO ()
+run = do
+  res <- runEitherT queries
+  case res of
+    Left err -> putStrLn $ "Error: " ++ show err
+    Right (pos, msg, em) -> do
+      print pos
+      print msg
+      print em

servant-examples/tutorial/T9.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+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.JQuery
+import System.Random
+
+import qualified Data.Text                  as T
+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 :: String
+apiJS = jsForAPI api
+
+writeJSFiles :: IO ()
+writeJSFiles = do
+  writeFile "tutorial/t9/api.js" apiJS
+  jq <- readFile =<< JQ.file
+  writeFile "tutorial/t9/jq.js" jq
+
+app :: Application
+app = serve api' server'

servant-examples/tutorial/t8-main.hs

@@ -0,0 +1,4 @@
+import T8
+
+main :: IO ()
+main = run

servant-examples/tutorial/t9/index.html

@@ -0,0 +1,26 @@
+<!DOCTYPE html>
+<html lang="en">
+  <head>
+    <meta name="viewport" content="width=device-width, initial-scale=1">
+    <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
+    <title>Tutorial - 9 - servant-jquery</title>
+  </head>
+  <body>
+  <h1>Books</h1>
+  <input type="search" name="q" id="q" placeholder="Search author or book title..." />
+  <div>
+    <p>Results for <strong id="query">""</strong></p>
+    <ul id="results">
+    </ul>
+  </div>
+  <hr />
+  <h1>Approximating &pi;</h1>
+  <p>Count: <span id="count">0</span></p>
+  <p>Successes: <span id="successes">0</span></p>
+  <p id="pi"></p>
+
+  <script type="text/javascript" src="/jq.js"></script>
+  <script type="text/javascript" src="/api.js"></script>
+  <script type="text/javascript" src="/ui.js"></script>
+
+  </body>

servant-examples/tutorial/t9/ui.js

@@ -0,0 +1,61 @@
+/* book search */
+function updateResults(data)
+{
+  console.log(data);
+  $('#results').html("");
+  $('#query').text("\"" + data.query + "\"");
+  for(var i = 0; i < data.results.length; i++)
+  {
+    $('#results').append(renderBook(data.results[i]));
+  }
+}
+
+function renderBook(book)
+{
+  var li = '<li><strong>' + book.title + '</strong>, <i>'
+         + book.author + '</i> - ' + book.year + '</li>';
+  return li;
+}
+
+function searchBooks()
+{
+  var q = $('#q').val();
+  getbooks(q, updateResults, console.log)
+}
+
+searchBooks();
+$('#q').keyup(function() {
+  searchBooks();
+});
+
+/* approximating pi */
+var count = 0;
+var successes = 0;
+
+function f(data)
+{
+  var x = data.x, y = data.y;
+  if(x*x + y*y <= 1)
+  {
+    successes++;
+  }
+
+  count++;
+
+  update('#count', count);
+  update('#successes', successes);
+  update('#pi', 4*successes/count);
+}
+
+function update(id, val)
+{
+  $(id).text(val);
+}
+
+function refresh()
+{
+  getpoint(f, console.log);
+}
+
+window.setInterval(refresh, 200);
+

servant-examples/tutorial/tutorial.hs

@@ -0,0 +1,39 @@
+import Network.Wai
+import Network.Wai.Handler.Warp
+import System.Environment
+
+import qualified T1
+import qualified T2
+import qualified T3
+import qualified T4
+import qualified T5
+import qualified T6
+import qualified T7
+import qualified T9
+import qualified T10
+
+app :: String -> (Application -> IO ()) -> IO ()
+app n f = case n of
+  "1" -> f T1.app
+  "2" -> f T2.app
+  "3" -> f T3.app
+  "4" -> f T4.app
+  "5" -> f T5.app
+  "6" -> f T6.app
+  "7" -> f T7.app
+  "8" -> f T3.app
+  "9" -> T9.writeJSFiles >> f T9.app
+  "10" -> f T10.app
+  _   -> usage
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [n] -> app n (run 8081)
+    _   -> usage
+
+usage :: IO ()
+usage = do
+  putStrLn "Usage:\t tutorial N"
+  putStrLn "\t\twhere N is the number of the example you want to run."