├── .ghci ├── README.md ├── .gitignore ├── static └── screen.css ├── snaplets └── api │ └── snaplets │ └── todos │ └── snaplets │ └── postgresql-simple │ └── devel.cfg ├── src ├── api │ ├── Types.hs │ ├── Core.hs │ └── services │ │ └── TodoService.hs ├── Application.hs ├── Site.hs └── Main.hs └── snap-api-tutorial.cabal /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -hide-package MonadCatchIO-mtl 3 | :set -hide-package monads-fd 4 | :set -XOverloadedStrings 5 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A REST API in Haskell and Snap 2 | 3 | Repository following the blog post [located here](https://robots.thoughtbot.com/a-rest-api-with-haskell-and-snap). 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Created by https://www.gitignore.io 2 | 3 | ### Haskell ### 4 | dist 5 | cabal-dev 6 | *.o 7 | *.hi 8 | *.chi 9 | *.chs.h 10 | *.dyn_o 11 | *.dyn_hi 12 | .virtualenv 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | cabal.config 18 | *.prof 19 | *.aux 20 | *.hp 21 | *.log 22 | .DS_Store 23 | -------------------------------------------------------------------------------- /static/screen.css: -------------------------------------------------------------------------------- 1 | html { 2 | padding: 0; 3 | margin: 0; 4 | background-color: #ffffff; 5 | font-family: Verdana, Helvetica, sans-serif; 6 | } 7 | body { 8 | padding: 0; 9 | margin: 0; 10 | } 11 | a { 12 | text-decoration: underline; 13 | } 14 | a :hover { 15 | cursor: pointer; 16 | text-decoration: underline; 17 | } 18 | img { 19 | border: none; 20 | } 21 | #content { 22 | padding-left: 1em; 23 | } 24 | #info { 25 | font-size: 60%; 26 | } 27 | -------------------------------------------------------------------------------- /snaplets/api/snaplets/todos/snaplets/postgresql-simple/devel.cfg: -------------------------------------------------------------------------------- 1 | host = "localhost" 2 | port = 5432 3 | user = "postgres" 4 | pass = "" 5 | db = "testdb" 6 | 7 | # Nmuber of distinct connection pools to maintain. The smallest acceptable 8 | # value is 1. 9 | numStripes = 1 10 | 11 | # Number of seconds an unused resource is kept open. The smallest acceptable 12 | # value is 0.5 seconds. 13 | idleTime = 5 14 | 15 | # Maximum number of resources to keep open per stripe. The smallest 16 | # acceptable value is 1. 17 | maxResourcesPerStripe = 20 18 | -------------------------------------------------------------------------------- /src/api/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | module Api.Types where 5 | 6 | import Control.Applicative 7 | import qualified Data.Text as T 8 | import Data.Aeson 9 | import Snap.Snaplet.PostgresqlSimple 10 | 11 | data Todo = Todo 12 | { id :: Int 13 | , text :: T.Text 14 | } 15 | 16 | instance FromRow Todo where 17 | fromRow = Todo <$> field 18 | <*> field 19 | 20 | instance ToJSON Todo where 21 | toJSON (Todo id text) = object [ "id" .= id, "text" .= text ] 22 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | This module defines our application's state type and an alias for its 5 | -- handler monad. 6 | module Application where 7 | 8 | ------------------------------------------------------------------------------ 9 | import Api.Core 10 | import Control.Lens 11 | import Snap.Snaplet 12 | import Snap.Snaplet.Heist 13 | import Snap.Snaplet.Auth 14 | import Snap.Snaplet.Session 15 | 16 | ------------------------------------------------------------------------------ 17 | data App = App { _api :: Snaplet Api } 18 | 19 | makeLenses ''App 20 | 21 | ------------------------------------------------------------------------------ 22 | type AppHandler = Handler App App 23 | -------------------------------------------------------------------------------- /src/api/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Api.Core where 5 | 6 | import Api.Services.TodoService 7 | import Control.Lens 8 | import Snap.Core 9 | import Snap.Snaplet 10 | import qualified Data.ByteString.Char8 as B 11 | 12 | data Api = Api { _todoService :: Snaplet TodoService } 13 | 14 | makeLenses ''Api 15 | 16 | apiRoutes :: [(B.ByteString, Handler b Api ())] 17 | apiRoutes = [("status", method GET respondOk)] 18 | 19 | respondOk :: Handler b Api () 20 | respondOk = do 21 | modifyResponse . setResponseCode $ 200 22 | 23 | apiInit :: SnapletInit b Api 24 | apiInit = makeSnaplet "api" "Core Api" Nothing $ do 25 | ts <- nestSnaplet "todos" todoService todoServiceInit 26 | addRoutes apiRoutes 27 | return $ Api ts 28 | -------------------------------------------------------------------------------- /src/api/services/TodoService.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module Api.Services.TodoService where 6 | 7 | import Api.Types 8 | import Control.Lens 9 | import Control.Monad.State.Class 10 | import Data.Aeson 11 | import Snap.Core 12 | import Snap.Snaplet 13 | import Snap.Snaplet.PostgresqlSimple 14 | import qualified Data.ByteString.Char8 as B 15 | 16 | data TodoService = TodoService { _pg :: Snaplet Postgres } 17 | 18 | makeLenses ''TodoService 19 | 20 | todoRoutes :: [(B.ByteString, Handler b TodoService ())] 21 | todoRoutes = [("/", method GET getTodos), ("/", method POST createTodo)] 22 | 23 | createTodo :: Handler b TodoService () 24 | createTodo = do 25 | todoTextParam <- getPostParam "text" 26 | execute "INSERT INTO todos (text) VALUES (?)" (Only todoTextParam) 27 | modifyResponse $ setResponseCode 201 28 | 29 | getTodos :: Handler b TodoService () 30 | getTodos = do 31 | todos <- query_ "SELECT * FROM todos" 32 | modifyResponse $ setHeader "Content-Type" "application/json" 33 | writeLBS . encode $ (todos :: [Todo]) 34 | 35 | todoServiceInit :: SnapletInit b TodoService 36 | todoServiceInit = makeSnaplet "todos" "Todo Service" Nothing $ do 37 | pg <- nestSnaplet "pg" pg pgsInit 38 | addRoutes todoRoutes 39 | return $ TodoService pg 40 | 41 | instance HasPostgres (Handler b TodoService) where 42 | getPostgresState = with pg get 43 | -------------------------------------------------------------------------------- /src/Site.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | This module is where all the routes and handlers are defined for your 5 | -- site. The 'app' function is the initializer that combines everything 6 | -- together and is exported by this module. 7 | module Site 8 | ( app 9 | ) where 10 | 11 | ------------------------------------------------------------------------------ 12 | import Api.Core 13 | import Control.Applicative 14 | import Data.ByteString (ByteString) 15 | import qualified Data.Text as T 16 | import Snap.Core 17 | import Snap.Snaplet 18 | import Snap.Snaplet.Auth 19 | import Snap.Snaplet.Auth.Backends.JsonFile 20 | import Snap.Snaplet.Heist 21 | import Snap.Snaplet.Session.Backends.CookieSession 22 | import Snap.Util.FileServe 23 | import Heist 24 | import qualified Heist.Interpreted as I 25 | ------------------------------------------------------------------------------ 26 | import Application 27 | 28 | 29 | ------------------------------------------------------------------------------ 30 | -- | The application's routes. 31 | routes :: [(ByteString, Handler App App ())] 32 | routes = [] 33 | 34 | 35 | ------------------------------------------------------------------------------ 36 | -- | The application initializer. 37 | app :: SnapletInit App App 38 | app = makeSnaplet "app" "An snaplet example application." Nothing $ do 39 | api <- nestSnaplet "api" api apiInit 40 | addRoutes routes 41 | return $ App api 42 | -------------------------------------------------------------------------------- /snap-api-tutorial.cabal: -------------------------------------------------------------------------------- 1 | Name: snap-api-tutorial 2 | Version: 0.1 3 | Synopsis: Project Synopsis Here 4 | Description: Project Description Here 5 | License: AllRightsReserved 6 | Author: Author 7 | Maintainer: maintainer@example.com 8 | Stability: Experimental 9 | Category: Web 10 | Build-type: Simple 11 | Cabal-version: >=1.2 12 | 13 | Flag development 14 | Description: Whether to build the server in development (interpreted) mode 15 | Default: False 16 | 17 | Flag old-base 18 | default: False 19 | manual: False 20 | 21 | Executable snap-api-tutorial 22 | hs-source-dirs: src 23 | main-is: Main.hs 24 | 25 | Build-depends: 26 | MonadCatchIO-transformers >= 0.3.1 && < 0.4, 27 | aeson >= 0.11.2 && < 0.12, 28 | bytestring >= 0.10.6 && < 0.11, 29 | heist >= 0.14.1 && < 0.15, 30 | mtl >= 2.2.1 && < 2.3, 31 | postgresql-simple >= 0.5.1 && < 0.6, 32 | snap >= 0.14 && < 0.15, 33 | snap-core >= 0.9.8 && < 0.10, 34 | snap-loader-static >= 0.9.0 && < 0.10, 35 | snap-server >= 0.9.5 && < 0.10, 36 | snaplet-postgresql-simple >= 0.6.0 && < 0.7, 37 | text >= 1.2.1 && < 1.3, 38 | time >= 1.5.0 && < 1.6, 39 | xmlhtml >= 0.2.3 && < 0.3 40 | 41 | if flag(old-base) 42 | build-depends: 43 | base >= 4 && < 4.4, 44 | lens >= 3.7.6 && < 3.8 45 | else 46 | build-depends: 47 | base >= 4.4 && < 5, 48 | lens >= 3.7.6 && < 4.15 49 | 50 | if flag(development) 51 | build-depends: 52 | snap-loader-dynamic == 0.10.* 53 | cpp-options: -DDEVELOPMENT 54 | -- In development mode, speed is already going to suffer, so skip 55 | -- the fancy optimization flags. Additionally, disable all 56 | -- warnings. The hint library doesn't give an option to execute 57 | -- compiled code when there were also warnings, so disabling 58 | -- warnings allows quicker workflow. 59 | ghc-options: -threaded -w 60 | else 61 | if impl(ghc >= 6.12.0) 62 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 63 | -fno-warn-orphans -fno-warn-unused-do-bind 64 | else 65 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 66 | -fno-warn-orphans 67 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | {- 5 | 6 | NOTE: Don't modify this file unless you know what you are doing. If you are 7 | new to snap, start with Site.hs and Application.hs. This file contains 8 | boilerplate needed for dynamic reloading and is not meant for general 9 | consumption. 10 | 11 | Occasionally if we modify the way the dynamic reloader works and you want to 12 | upgrade, you might have to swap out this file for a newer version. But in 13 | most cases you'll never need to modify this code. 14 | 15 | -} 16 | module Main where 17 | 18 | ------------------------------------------------------------------------------ 19 | import Control.Exception (SomeException, try) 20 | import qualified Data.Text as T 21 | import Snap.Http.Server 22 | import Snap.Snaplet 23 | import Snap.Snaplet.Config 24 | import Snap.Core 25 | import System.IO 26 | import Site 27 | 28 | #ifdef DEVELOPMENT 29 | import Snap.Loader.Dynamic 30 | #else 31 | import Snap.Loader.Static 32 | #endif 33 | 34 | 35 | ------------------------------------------------------------------------------ 36 | -- | This is the entry point for this web server application. It supports 37 | -- easily switching between interpreting source and running statically compiled 38 | -- code. 39 | -- 40 | -- In either mode, the generated program should be run from the root of the 41 | -- project tree. When it is run, it locates its templates, static content, and 42 | -- source files in development mode, relative to the current working directory. 43 | -- 44 | -- When compiled with the development flag, only changes to the libraries, your 45 | -- cabal file, or this file should require a recompile to be picked up. 46 | -- Everything else is interpreted at runtime. There are a few consequences of 47 | -- this. 48 | -- 49 | -- First, this is much slower. Running the interpreter takes a significant 50 | -- chunk of time (a couple tenths of a second on the author's machine, at this 51 | -- time), regardless of the simplicity of the loaded code. In order to 52 | -- recompile and re-load server state as infrequently as possible, the source 53 | -- directories are watched for updates, as are any extra directories specified 54 | -- below. 55 | -- 56 | -- Second, the generated server binary is MUCH larger, since it links in the 57 | -- GHC API (via the hint library). 58 | -- 59 | -- Third, and the reason you would ever want to actually compile with 60 | -- development mode, is that it enables a faster development cycle. You can 61 | -- simply edit a file, save your changes, and hit reload to see your changes 62 | -- reflected immediately. 63 | -- 64 | -- When this is compiled without the development flag, all the actions are 65 | -- statically compiled in. This results in faster execution, a smaller binary 66 | -- size, and having to recompile the server for any code change. 67 | -- 68 | main :: IO () 69 | main = do 70 | -- Depending on the version of loadSnapTH in scope, this either enables 71 | -- dynamic reloading, or compiles it without. The last argument to 72 | -- loadSnapTH is a list of additional directories to watch for changes to 73 | -- trigger reloads in development mode. It doesn't need to include source 74 | -- directories, those are picked up automatically by the splice. 75 | (conf, site, cleanup) <- $(loadSnapTH [| getConf |] 76 | 'getActions 77 | []) 78 | 79 | _ <- try $ httpServe conf site :: IO (Either SomeException ()) 80 | cleanup 81 | 82 | 83 | ------------------------------------------------------------------------------ 84 | -- | This action loads the config used by this application. The loaded config 85 | -- is returned as the first element of the tuple produced by the loadSnapTH 86 | -- Splice. The type is not solidly fixed, though it must be an IO action that 87 | -- produces the same type as 'getActions' takes. It also must be an instance of 88 | -- Typeable. If the type of this is changed, a full recompile will be needed to 89 | -- pick up the change, even in development mode. 90 | -- 91 | -- This action is only run once, regardless of whether development or 92 | -- production mode is in use. 93 | getConf :: IO (Config Snap AppConfig) 94 | getConf = commandLineAppConfig defaultConfig 95 | 96 | 97 | ------------------------------------------------------------------------------ 98 | -- | This function generates the the site handler and cleanup action from the 99 | -- configuration. In production mode, this action is only run once. In 100 | -- development mode, this action is run whenever the application is reloaded. 101 | -- 102 | -- Development mode also makes sure that the cleanup actions are run 103 | -- appropriately before shutdown. The cleanup action returned from loadSnapTH 104 | -- should still be used after the server has stopped handling requests, as the 105 | -- cleanup actions are only automatically run when a reload is triggered. 106 | -- 107 | -- This sample doesn't actually use the config passed in, but more 108 | -- sophisticated code might. 109 | getActions :: Config Snap AppConfig -> IO (Snap (), IO ()) 110 | getActions conf = do 111 | (msgs, site, cleanup) <- runSnaplet 112 | (appEnvironment =<< getOther conf) app 113 | hPutStrLn stderr $ T.unpack msgs 114 | return (site, cleanup) 115 | --------------------------------------------------------------------------------