├── .bin ├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── circle.yml ├── docker ├── Dockerfile-happstack ├── Dockerfile-scotty ├── Dockerfile-servant ├── Dockerfile-snap ├── Dockerfile-spock └── Dockerfile-yesod ├── sloppy.json ├── stack.yaml ├── todobackend-common ├── LICENSE ├── Setup.hs ├── src │ └── TodoBackend │ │ ├── Model.hs │ │ └── Utils.hs └── todobackend-common.cabal ├── todobackend-happstack ├── LICENSE ├── Setup.hs ├── src │ └── Main.hs └── todobackend-happstack.cabal ├── todobackend-scotty ├── LICENSE ├── Setup.hs ├── src │ └── Main.hs └── todobackend-scotty.cabal ├── todobackend-servant ├── .gitignore ├── LICENSE ├── Setup.hs ├── src │ └── Main.hs └── todobackend-servant.cabal ├── todobackend-snap ├── LICENSE ├── Setup.hs ├── src │ └── Main.hs └── todobackend-snap.cabal ├── todobackend-spock ├── LICENSE ├── Setup.hs ├── src │ └── Main.hs └── todobackend-spock.cabal └── todobackend-yesod ├── LICENSE ├── Setup.hs ├── src └── Main.hs └── todobackend-yesod.cabal /.bin: -------------------------------------------------------------------------------- 1 | .stack-work/install/x86_64-linux/lts-6.10/7.10.3/bin/ -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | .stack-work 3 | *.sqlite3 4 | 5 | client_session_key.aes 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | language: generic 4 | 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | # Ensure necessary system libraries are present 10 | addons: 11 | apt: 12 | packages: 13 | - libgmp-dev 14 | 15 | before_install: 16 | # Download and unpack the stack executable 17 | - mkdir -p ~/.local/bin 18 | - export PATH=$HOME/.local/bin:$PATH 19 | - travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 20 | 21 | install: 22 | # Build dependencies 23 | - stack --no-terminal --install-ghc test --only-dependencies -j 1 24 | 25 | script: 26 | # Build the package, its tests, and its docs and run the tests 27 | - stack --no-terminal test --haddock --no-haddock-deps 28 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | UNAME="$(shell uname -s)" 2 | 3 | all: happstack.docker scotty.docker servant.docker snap.docker spock.docker yesod.docker 4 | 5 | %.bin: 6 | ifeq ($(UNAME), "Darwin") 7 | docker run --rm -it -v ~/.stack:/root/.stack -v `pwd`:/code -w /code fpco/stack-build bash -c 'stack build todobackend-$(basename $@) --allow-different-user' 8 | else 9 | stack build todobackend-$(basename $@) 10 | endif 11 | 12 | %.docker: %.bin 13 | docker build -f docker/Dockerfile-$(basename $@) -t jhedev/todobackend-haskell:$(basename $@) . 14 | 15 | push: 16 | docker push jhedev/todobackend-haskell 17 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # todobackend-haskell 2 | 3 | [![build status](https://circleci.com/gh/jhedev/todobackend-haskell.svg?style=shield)](https://circleci.com/gh/jhedev/todobackend-haskell/tree/master) 4 | 5 | This repository provides different Haskell implementations for [todobackend](http://www.todobackend.com/). 6 | 7 | The [`todobackend-common`](https://github.com/jhedev/todobackend-haskell/tree/master/todobackend-common) package 8 | implements common functionality, such as the model and some utils. 9 | 10 | ### Demos 11 | 12 | Hosting sponsored by **[sloppy.io](https://sloppy.io)**. 13 | 14 | The running demos can be found at: 15 | 16 | * [todobackend-happstack.sloppy.zone](https://todobackend-happstack.sloppy.zone) 17 | * [todobackend-scotty.sloppy.zone](https://todobackend-scotty.sloppy.zone) 18 | * [todobackend-servant.sloppy.zone](https://todobackend-servant.sloppy.zone) 19 | * [todobackend-snap.sloppy.zone](https://todobackend-snap.sloppy.zone) 20 | * [todobackend-spock.sloppy.zone](https://todobackend-spock.sloppy.zone) 21 | * [todobackend-yesod.sloppy.zone](https://todobackend-yesod.sloppy.zone) 22 | 23 | ### Building and running locally 24 | 25 | Make sure you have [`stack`](https://github.com/commercialhaskell/stack) installed. 26 | 27 | To build and run `todobackend-scotty` execute the following: 28 | 29 | ``` 30 | stack build todobackend-scotty # This will take some time 31 | PORT=3000 URL=http://localhost:3000 stack exec todobackend-scotty 32 | ``` 33 | 34 | Similar for the other implementations. 35 | 36 | ### Docker images 37 | 38 | To run the docker container of the scotty implementation: 39 | 40 | ``` 41 | docker run --rm -it -p 3000:3000 -e URL=http://localhost:3000 jhedev/todobackend-haskell:scotty 42 | ``` 43 | 44 | The application is now running on port 3000. For any other implementation just replace `scotty` with `servant`, `snap`, `spock` or `yesod`. 45 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | pre: 3 | - sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-4.6 20 4 | - sudo update-alternatives --install /usr/bin/g++ g++ /usr/bin/g++-4.6 20 5 | - sudo update-alternatives --install /usr/bin/gcc gcc /usr/bin/gcc-4.9 10 6 | - sudo update-alternatives --install /usr/bin/g++ g++ /usr/bin/g++-4.9 10 7 | ghc: 8 | version: 7.10.1 9 | dependencies: 10 | pre: 11 | - wget -q -O- https://s3.amazonaws.com/download.fpcomplete.com/ubuntu/fpco.key | sudo apt-key add - 12 | - echo 'deb http://download.fpcomplete.com/ubuntu/precise stable main'|sudo tee /etc/apt/sources.list.d/fpco.list 13 | - sudo apt-get update && sudo apt-get -y install stack 14 | override: 15 | - stack --version 16 | - stack --install-ghc --no-terminal build --only-snapshot -j 1 17 | cache_directories: 18 | - ~/.stack 19 | 20 | test: 21 | pre: 22 | - stack build 23 | override: 24 | - stack test 25 | -------------------------------------------------------------------------------- /docker/Dockerfile-happstack: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-happstack /usr/bin/todobackend-happstack 6 | 7 | CMD todobackend-happstack 8 | -------------------------------------------------------------------------------- /docker/Dockerfile-scotty: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-scotty /usr/bin/todobackend-scotty 6 | 7 | CMD todobackend-scotty 8 | -------------------------------------------------------------------------------- /docker/Dockerfile-servant: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-servant /usr/bin/todobackend-servant 6 | 7 | CMD todobackend-servant 8 | -------------------------------------------------------------------------------- /docker/Dockerfile-snap: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-snap /usr/bin/todobackend-snap 6 | 7 | CMD todobackend-snap 8 | -------------------------------------------------------------------------------- /docker/Dockerfile-spock: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-spock /usr/bin/todobackend-spock 6 | 7 | CMD todobackend-spock 8 | -------------------------------------------------------------------------------- /docker/Dockerfile-yesod: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | 3 | EXPOSE 3000 4 | ENV PORT=3000 5 | ADD .bin/todobackend-yesod /usr/bin/todobackend-yesod 6 | 7 | CMD todobackend-yesod 8 | -------------------------------------------------------------------------------- /sloppy.json: -------------------------------------------------------------------------------- 1 | { 2 | "project": "todobackend-haskell", 3 | "services": [ 4 | { 5 | "id": "backends", 6 | "apps": [ 7 | { 8 | "id": "happstack", 9 | "domain": { 10 | "type": "HTTP", 11 | "uri": "todobackend-happstack.sloppy.zone" 12 | }, 13 | "mem": 100, 14 | "image": "jhedev/todobackend-haskell:happstack", 15 | "force_pull_image": true, 16 | "instances": 1, 17 | "port_mappings": [ 18 | { 19 | "container_port": 3000 20 | } 21 | ], 22 | "env": { 23 | "URL": "http://todobackend-happstack.sloppy.zone" 24 | } 25 | }, 26 | { 27 | "id": "scotty", 28 | "domain": { 29 | "type": "HTTP", 30 | "uri": "todobackend-scotty.sloppy.zone" 31 | }, 32 | "mem": 100, 33 | "image": "jhedev/todobackend-haskell:scotty", 34 | "force_pull_image": true, 35 | "instances": 1, 36 | "port_mappings": [ 37 | { 38 | "container_port": 3000 39 | } 40 | ], 41 | "env": { 42 | "URL": "http://todobackend-scotty.sloppy.zone" 43 | } 44 | }, 45 | { 46 | "id": "servant", 47 | "domain": { 48 | "type": "HTTP", 49 | "uri": "todobackend-servant.sloppy.zone" 50 | }, 51 | "mem": 100, 52 | "image": "jhedev/todobackend-haskell:servant", 53 | "force_pull_image": true, 54 | "instances": 1, 55 | "port_mappings": [ 56 | { 57 | "container_port": 3000 58 | } 59 | ], 60 | "env": { 61 | "URL": "http://todobackend-servant.sloppy.zone" 62 | } 63 | }, 64 | { 65 | "id": "snap", 66 | "domain": { 67 | "type": "HTTP", 68 | "uri": "todobackend-snap.sloppy.zone" 69 | }, 70 | "mem": 100, 71 | "image": "jhedev/todobackend-haskell:snap", 72 | "force_pull_image": true, 73 | "instances": 1, 74 | "port_mappings": [ 75 | { 76 | "container_port": 3000 77 | } 78 | ], 79 | "env": { 80 | "URL": "http://todobackend-snap.sloppy.zone" 81 | } 82 | }, 83 | { 84 | "id": "spock", 85 | "domain": { 86 | "type": "HTTP", 87 | "uri": "todobackend-spock.sloppy.zone" 88 | }, 89 | "mem": 100, 90 | "image": "jhedev/todobackend-haskell:spock", 91 | "force_pull_image": true, 92 | "instances": 1, 93 | "port_mappings": [ 94 | { 95 | "container_port": 3000 96 | } 97 | ], 98 | "env": { 99 | "URL": "http://todobackend-spock.sloppy.zone" 100 | } 101 | }, 102 | { 103 | "id": "yesod", 104 | "domain": { 105 | "type": "HTTP", 106 | "uri": "todobackend-yesod.sloppy.zone" 107 | }, 108 | "mem": 100, 109 | "image": "jhedev/todobackend-haskell:yesod", 110 | "force_pull_image": true, 111 | "instances": 1, 112 | "port_mappings": [ 113 | { 114 | "container_port": 3000 115 | } 116 | ], 117 | "env": { 118 | "URL": "http://todobackend-yesod.sloppy.zone" 119 | } 120 | } 121 | ] 122 | } 123 | ] 124 | } 125 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - todobackend-common 4 | - todobackend-happstack 5 | - todobackend-scotty 6 | - todobackend-servant 7 | - todobackend-snap 8 | - todobackend-spock 9 | - todobackend-yesod 10 | extra-deps: 11 | - Spock-0.13.0.0@sha256:163ef2698fed8f5801428d8dbe794fd126415a5ff3304b227750fdc4037497be,3745 12 | - Spock-core-0.13.0.0@sha256:06e007f23c47bdda52d2927da54160d73f1b6f51a977f3ca9087275698db8f0a,3400 13 | - focus-0.1.5.2@sha256:fc5c76a5be3a9a1c456106d6f389939299c7e05a1a24938b909f043e36a3e37b,1519 14 | - heist-1.1.0.1@sha256:f0f7bbdb19e61e2adbcebcce030b5af1d631b137ab99b9f9f0ed397130338528,9311 15 | - map-syntax-0.3@sha256:9b92c51bcaf1d55f60f8aaef9a96adb29acb77112631fa4110fd5dcae54be7a6,2420 16 | - pwstore-fast-2.4.4@sha256:9b6a37510d8b9f37f409a8ab3babac9181afcaaa3fce8ba1c131a7ed3de30698,1351 17 | - reroute-0.5.0.0@sha256:3360747cdc700c9808a38bff48b75926efa443d4af282396082329a218a8d9d3,2446 18 | - snap-1.1.3.0@sha256:0c0814d2ab1c3d5f22cef4615b2913ded18e87710ea6febdbe6e3ab8d9838735,8872 19 | - stm-containers-0.2.16@sha256:e98efa8dcf0045ea8a78a04b4e2763cf2d8bc33aad0750e2f30a67f8f4e933b1,8454 20 | - xmlhtml-0.2.5.2@sha256:3f0990f725551985d777e8edb5563fe99aee998f1fde6a7633f720f76df54701,46997 21 | allow-newer: true 22 | resolver: lts-18.8 23 | -------------------------------------------------------------------------------- /todobackend-common/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-common/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-common/src/TodoBackend/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE StandaloneDeriving #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | module TodoBackend.Model where 15 | 16 | import Control.Monad (mzero) 17 | import Control.Monad.Logger 18 | import Control.Monad.Trans.Resource (runResourceT, ResourceT) 19 | import Data.Aeson 20 | import Data.Aeson.TH 21 | import Data.Maybe (fromMaybe) 22 | import qualified Database.Persist.Sqlite as Sqlite 23 | import qualified Data.Text as Text 24 | import Database.Persist.TH 25 | import Web.PathPieces 26 | 27 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 28 | Todo 29 | title String 30 | completed Bool 31 | order Int 32 | deriving Show 33 | |] 34 | 35 | data TodoResponse = TodoResponse 36 | { trid :: TodoId 37 | , trurl :: String 38 | , trtitle :: String 39 | , trcompleted :: Bool 40 | , trorder :: Int 41 | } deriving (Show) 42 | 43 | $(deriveToJSON defaultOptions { fieldLabelModifier = drop 2} 44 | ''TodoResponse) 45 | 46 | mkTodoResponse :: String -> Sqlite.Entity Todo -> TodoResponse 47 | mkTodoResponse rootUrl (Sqlite.Entity key Todo{..}) = 48 | TodoResponse key todoUrl todoTitle todoCompleted todoOrder 49 | where 50 | todoUrl = rootUrl ++ "/todos/" ++ Text.unpack (toPathPiece key) 51 | 52 | data TodoAction = TodoAction 53 | { actTitle :: Maybe String 54 | , actCompleted :: Maybe Bool 55 | , actOrder :: Maybe Int 56 | } deriving Show 57 | 58 | instance FromJSON TodoAction where 59 | parseJSON (Object o) = TodoAction 60 | <$> o .:? "title" 61 | <*> o .:? "completed" 62 | <*> o .:? "order" 63 | parseJSON _ = mzero 64 | 65 | instance ToJSON TodoAction where 66 | toJSON (TodoAction mTitle mCompl mOrder) = noNullsObject 67 | [ "title" .= mTitle 68 | , "completed" .= mCompl 69 | , "order" .= mOrder 70 | ] 71 | where 72 | noNullsObject = object . filter notNull 73 | notNull (_, Null) = False 74 | notNull _ = True 75 | 76 | actionToTodo :: TodoAction -> Todo 77 | actionToTodo (TodoAction mTitle mCompleted mOrder) = Todo title completed order 78 | where 79 | title = fromMaybe "" mTitle 80 | completed = fromMaybe False mCompleted 81 | order = fromMaybe 0 mOrder 82 | 83 | actionToUpdates :: TodoAction -> [Sqlite.Update Todo] 84 | actionToUpdates act = updateTitle 85 | ++ updateCompl 86 | ++ updateOrd 87 | where 88 | updateTitle = maybe [] (\title -> [TodoTitle Sqlite.=. title]) 89 | (actTitle act) 90 | updateCompl = maybe [] (\compl -> [TodoCompleted Sqlite.=. compl]) 91 | (actCompleted act) 92 | updateOrd = maybe [] (\ord -> [TodoOrder Sqlite.=. ord]) 93 | (actOrder act) 94 | 95 | runDb :: Sqlite.SqlPersistT (ResourceT (NoLoggingT IO)) a -> IO a 96 | runDb = runNoLoggingT . runResourceT . Sqlite.withSqliteConn "dev.sqlite3" . Sqlite.runSqlConn 97 | -------------------------------------------------------------------------------- /todobackend-common/src/TodoBackend/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module TodoBackend.Utils where 3 | 4 | import Network.HTTP.Types 5 | import Network.Wai 6 | import Network.Wai.Middleware.AddHeaders 7 | 8 | allowCors :: Middleware 9 | allowCors = addHeaders [ 10 | ("Access-Control-Allow-Origin", "*"), 11 | ("Access-Control-Allow-Headers", "Accept, Content-Type"), 12 | ("Access-Control-Allow-Methods", "GET, HEAD, POST, DELETE, OPTIONS, PUT, PATCH") 13 | ] 14 | 15 | allowOptions :: Middleware 16 | allowOptions app req resp = case requestMethod req of 17 | "OPTIONS" -> resp $ responseLBS status200 [] "Ok" 18 | _ -> app req resp 19 | -------------------------------------------------------------------------------- /todobackend-common/todobackend-common.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-common 2 | version: 0.1.0.0 3 | synopsis: Common stuff (e.g. model) for todobackends 4 | description: Please see README.md 5 | homepage: http://github.com/jhedev/todobackend-haskell 6 | license: MIT 7 | license-file: LICENSE 8 | author: Joel Hermanns 9 | maintainer: joel.hermanns@gmail.com 10 | -- copyright: 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: TodoBackend.Model 19 | , TodoBackend.Utils 20 | build-depends: base >= 4.7 && < 5 21 | , aeson 22 | , http-types 23 | , monad-logger 24 | , path-pieces 25 | , persistent 26 | , persistent-sqlite 27 | , persistent-template 28 | , resourcet 29 | , text 30 | , transformers 31 | , wai 32 | , wai-extra 33 | 34 | default-language: Haskell2010 35 | 36 | source-repository head 37 | type: git 38 | location: https://github.com/jhedev/todobackend 39 | -------------------------------------------------------------------------------- /todobackend-happstack/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-happstack/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-happstack/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | import Control.Monad.Reader 4 | import Data.Aeson 5 | import qualified Data.ByteString.Lazy.Char8 as L 6 | import qualified Database.Persist.Sqlite as Sqlite 7 | import Happstack.Server 8 | import System.Environment 9 | import Web.PathPieces 10 | 11 | import TodoBackend.Model 12 | 13 | data Config = Config String 14 | 15 | main :: IO () 16 | main = do 17 | runDb $ Sqlite.runMigration migrateAll 18 | p <- read <$> getEnv "PORT" 19 | url <- getEnv "URL" 20 | let conf = Config url 21 | simpleHTTP (nullConf { port = p}) $ flip runReaderT conf $ do 22 | mapM_ (uncurry setHeaderM) [ ("Access-Control-Allow-Origin", "*") 23 | , ("Access-Control-Allow-Headers", "Accept, Content-Type") 24 | , ("Access-Control-Allow-Methods", "GET, HEAD, POST, DELETE, OPTIONS, PUT, PATCH") 25 | ] 26 | msum [ method OPTIONS >>= \_ -> ok $ toResponse ("ok" :: String) 27 | , todosByIdApi 28 | , todosListApi 29 | ] 30 | 31 | type App a = ReaderT Config (ServerPartT IO) a 32 | 33 | getBody :: App L.ByteString 34 | getBody = do 35 | req <- askRq 36 | mbody <- liftIO $ takeRequestBody req 37 | case mbody of 38 | Nothing -> return "" 39 | Just rb -> return $ unBody rb 40 | 41 | getTodoActionBody :: App (Maybe TodoAction) 42 | getTodoActionBody = decode <$> getBody 43 | 44 | jsonResponse :: ToJSON a => a -> App Response 45 | jsonResponse = ok . toResponseBS "application/json" . encode 46 | 47 | todoResponse :: Sqlite.Entity Todo -> App Response 48 | todoResponse e = do 49 | Config url <- ask 50 | jsonResponse . mkTodoResponse url $ e 51 | 52 | todosByIdApi :: App Response 53 | todosByIdApi = dir "todos" $ path $ \tid -> 54 | case fromPathPiece tid of 55 | Nothing -> badRequest $ toResponse ("Invalid id" :: String) 56 | Just tid' -> msum [ getTodo tid' 57 | , patchTodo tid' 58 | , deleteTodo tid' 59 | ] 60 | where 61 | getTodo :: TodoId -> App Response 62 | getTodo tid = do 63 | method GET 64 | todoM <- liftIO $ readTodo tid 65 | case todoM of 66 | Nothing -> notFound $ toResponse ("Id not found" :: String) 67 | Just todo -> todoResponse $ Sqlite.Entity tid todo 68 | patchTodo :: TodoId -> App Response 69 | patchTodo tid = do 70 | method PATCH 71 | mtact <- getTodoActionBody 72 | case mtact of 73 | Nothing -> badRequest $ toResponse ("Invalid request body" :: String) 74 | Just tact -> do 75 | let todoUp = actionToUpdates tact 76 | todo <- liftIO $ runDb $ Sqlite.updateGet tid todoUp 77 | todoResponse (Sqlite.Entity tid todo) 78 | 79 | deleteTodo :: TodoId -> App Response 80 | deleteTodo tid = do 81 | method DELETE 82 | liftIO $ runDb $ Sqlite.delete tid 83 | ok $ toResponse ("deleted" :: String) 84 | 85 | 86 | readTodo :: TodoId -> IO (Maybe Todo) 87 | readTodo tid = runDb $ Sqlite.get tid 88 | 89 | todosListApi :: App Response 90 | todosListApi = dir "todos" $ 91 | msum [ getAll 92 | , create 93 | , delete 94 | ] 95 | where 96 | getAll = do 97 | method GET 98 | todos <- liftIO $ runDb $ Sqlite.selectList [] ([] :: [Sqlite.SelectOpt Todo]) 99 | Config url <- ask 100 | let todosResp = map (mkTodoResponse url) todos 101 | jsonResponse todosResp 102 | create = do 103 | method POST 104 | mtact <- getTodoActionBody 105 | case mtact of 106 | Nothing -> badRequest $ toResponse ("bad request" :: String) 107 | Just tact -> do 108 | let todo = actionToTodo tact 109 | tid <- liftIO $ runDb $ Sqlite.insert todo 110 | todoResponse $ Sqlite.Entity tid todo 111 | delete :: App Response 112 | delete = do 113 | method DELETE 114 | liftIO $ runDb $ Sqlite.deleteWhere ([] :: [Sqlite.Filter Todo]) 115 | ok $ toResponse ("deleted" :: String) 116 | -------------------------------------------------------------------------------- /todobackend-happstack/todobackend-happstack.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-happstack 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Happstack 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-happstack 16 | main-is: Main.hs 17 | ghc-options: -Wall 18 | -- other-modules: 19 | -- other-extensions: 20 | build-depends: base >=4.6 && <5 21 | , aeson 22 | , bytestring 23 | , happstack-server 24 | , mtl 25 | , path-pieces 26 | , persistent-sqlite 27 | , todobackend-common 28 | , transformers 29 | 30 | hs-source-dirs: src 31 | default-language: Haskell2010 -------------------------------------------------------------------------------- /todobackend-scotty/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-scotty/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-scotty/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Monad.IO.Class (liftIO) 3 | import qualified Database.Persist.Sqlite as Sqlite 4 | import Network.HTTP.Types.Status (status404) 5 | import System.Environment 6 | import Web.Scotty 7 | import Web.PathPieces 8 | 9 | import TodoBackend.Model 10 | import TodoBackend.Utils 11 | 12 | json' :: String -> Sqlite.Entity Todo -> ActionM () 13 | json' url = json . mkTodoResponse url 14 | 15 | jsonList :: String -> [Sqlite.Entity Todo] -> ActionM () 16 | jsonList url = json . map (mkTodoResponse url) 17 | 18 | main :: IO () 19 | main = do 20 | runDb $ Sqlite.runMigration migrateAll 21 | port <- read <$> getEnv "PORT" 22 | url <- getEnv "URL" 23 | scotty port $ do 24 | middleware allowCors 25 | middleware allowOptions 26 | get "/todos" $ do 27 | todos <- liftIO readTodos 28 | jsonList url todos 29 | get "/todos/:id" $ do 30 | pid <- param "id" 31 | actionOr404 pid (\tid -> do 32 | Just todo <- liftIO $ readTodo tid 33 | json' url (Sqlite.Entity tid todo)) 34 | patch "/todos/:id" $ do 35 | pid <- param "id" 36 | actionOr404 pid (\tid -> do 37 | todoAct <- jsonData 38 | let todoUp = actionToUpdates todoAct 39 | todo <- liftIO $ runDb $ Sqlite.updateGet tid todoUp 40 | json' url (Sqlite.Entity tid todo)) 41 | delete "/todos/:id" $ do 42 | pid <- param "id" 43 | actionOr404 pid (liftIO . deleteTodo) 44 | post "/todos" $ do 45 | todoAct <- jsonData 46 | let todo = actionToTodo todoAct 47 | tid <- liftIO $ insertTodo todo 48 | json' url (Sqlite.Entity tid todo) 49 | delete "/todos" $ liftIO $ runDb $ Sqlite.deleteWhere ([] :: [Sqlite.Filter Todo]) 50 | where 51 | readTodos :: IO [Sqlite.Entity Todo] 52 | readTodos = runDb $ Sqlite.selectList [] [] 53 | 54 | readTodo :: Sqlite.Key Todo -> IO (Maybe Todo) 55 | readTodo tid = runDb $ Sqlite.get tid 56 | 57 | deleteTodo :: Sqlite.Key Todo -> IO () 58 | deleteTodo tid = runDb $ Sqlite.delete tid 59 | 60 | insertTodo :: Todo -> IO (Sqlite.Key Todo) 61 | insertTodo todo = runDb $ Sqlite.insert todo 62 | 63 | actionOr404 pid action = case fromPathPiece pid of 64 | Nothing -> status status404 65 | Just tid -> action tid 66 | -------------------------------------------------------------------------------- /todobackend-scotty/todobackend-scotty.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-scotty 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Scotty 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-scotty 16 | main-is: Main.hs 17 | ghc-options: -Wall 18 | -- other-modules: 19 | -- other-extensions: 20 | build-depends: base >=4.6 && <5 21 | , http-types 22 | , scotty 23 | , path-pieces 24 | , persistent-sqlite 25 | , todobackend-common 26 | , transformers 27 | 28 | hs-source-dirs: src 29 | default-language: Haskell2010 -------------------------------------------------------------------------------- /todobackend-servant/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .stack-work 3 | *.sqlite3 4 | -------------------------------------------------------------------------------- /todobackend-servant/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-servant/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-servant/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | import qualified Control.Category as C 5 | import Control.Monad.IO.Class (liftIO) 6 | import Control.Monad.Reader (ReaderT, runReaderT, asks) 7 | import Control.Monad.Trans.Except 8 | import Data.Proxy 9 | import qualified Database.Persist.Sqlite as Sqlite 10 | import GHC.TypeLits (Nat) 11 | import Network.Wai 12 | import Network.Wai.Handler.Warp (run) 13 | import Servant 14 | import Servant.Server (hoistServer, err404) 15 | import System.Environment 16 | 17 | import TodoBackend.Model 18 | import TodoBackend.Utils 19 | 20 | 21 | data App = App 22 | { 23 | appRoot :: String 24 | } 25 | 26 | type TodoApi = "todos" :> Get '[JSON] [TodoResponse] 27 | :<|> "todos" :> Delete '[JSON] () 28 | :<|> "todos" :> ReqBody '[JSON] TodoAction :> PostCreated '[JSON] TodoResponse 29 | :<|> "todos" :> Capture "todoid" Integer :> Get '[JSON] TodoResponse 30 | :<|> "todos" :> Capture "todoid" Integer :> Delete '[JSON] () 31 | :<|> "todos" :> Capture "todoid" Integer :> ReqBody '[JSON] TodoAction :> Patch '[JSON] TodoResponse 32 | 33 | type AppM = ReaderT App Handler 34 | 35 | toResp :: Sqlite.Entity Todo -> AppM TodoResponse 36 | toResp todo = do 37 | url <- asks appRoot 38 | return $ mkTodoResponse url todo 39 | 40 | toRespL :: [Sqlite.Entity Todo] -> AppM [TodoResponse] 41 | toRespL todos = do 42 | url <- asks appRoot 43 | return $ map (mkTodoResponse url) todos 44 | 45 | todoApi :: Proxy TodoApi 46 | todoApi = Proxy 47 | 48 | getTodos :: AppM [TodoResponse] 49 | getTodos = do 50 | todos <- liftIO $ runDb $ Sqlite.selectList [] ([] :: [Sqlite.SelectOpt Todo]) 51 | toRespL todos 52 | 53 | deleteTodos :: AppM () 54 | deleteTodos = liftIO $ runDb $ Sqlite.deleteWhere ([] :: [Sqlite.Filter Todo]) 55 | 56 | getTodo :: Integer -> AppM TodoResponse 57 | getTodo tid = do 58 | let tKey = Sqlite.toSqlKey (fromIntegral tid) 59 | mtodo <- liftIO $ runDb $ Sqlite.get tKey 60 | case mtodo of 61 | Nothing -> throwError err404 62 | Just todo -> toResp $ Sqlite.Entity tKey todo 63 | 64 | deleteTodo :: Integer -> AppM () 65 | deleteTodo tid = do 66 | let tKey = Sqlite.toSqlKey (fromIntegral tid) 67 | liftIO $ runDb $ Sqlite.delete (tKey :: Sqlite.Key Todo) 68 | 69 | postTodo :: TodoAction -> AppM TodoResponse 70 | postTodo todoAct = do 71 | let todo = actionToTodo todoAct 72 | tid <- liftIO $ runDb $ Sqlite.insert todo 73 | toResp $ Sqlite.Entity tid todo 74 | 75 | patchTodo :: Integer -> TodoAction -> AppM TodoResponse 76 | patchTodo tid todoAct = do 77 | let tKey = Sqlite.toSqlKey (fromIntegral tid) 78 | updates = actionToUpdates todoAct 79 | todo <- liftIO $ runDb $ Sqlite.updateGet tKey updates 80 | toResp $ Sqlite.Entity tKey todo 81 | 82 | server :: ServerT TodoApi AppM 83 | server = getTodos 84 | :<|> deleteTodos 85 | :<|> postTodo 86 | :<|> getTodo 87 | :<|> deleteTodo 88 | :<|> patchTodo 89 | 90 | readerServer :: App -> Server TodoApi 91 | readerServer app = hoistServer todoApi nt server 92 | where 93 | nt :: AppM x -> Handler x 94 | nt = flip runReaderT app 95 | 96 | waiApp :: App -> Application 97 | waiApp app = allowCors $ allowOptions $ serve todoApi (readerServer app) 98 | 99 | main :: IO () 100 | main = do 101 | runDb $ Sqlite.runMigration migrateAll 102 | port <- read <$> getEnv "PORT" 103 | url <- getEnv "URL" 104 | run port $ waiApp (App url) 105 | -------------------------------------------------------------------------------- /todobackend-servant/todobackend-servant.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-servant 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Servant 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-servant 16 | main-is: Main.hs 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.6 && <5 20 | , either 21 | , mtl 22 | , persistent-sqlite 23 | , servant >= 0.12 24 | , servant-server >= 0.12 25 | , todobackend-common 26 | , transformers 27 | , wai 28 | , warp 29 | hs-source-dirs: src 30 | default-language: Haskell2010 31 | -------------------------------------------------------------------------------- /todobackend-snap/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-snap/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-snap/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Monad.IO.Class (liftIO) 3 | import Control.Monad.State.Class 4 | import Data.Aeson 5 | import qualified Data.ByteString.Char8 as C8 6 | import qualified Database.Persist.Sqlite as Sqlite 7 | import Snap 8 | import System.Environment 9 | 10 | import TodoBackend.Model 11 | 12 | data App = App 13 | { appRoot :: String 14 | } 15 | 16 | writeJSON :: (ToJSON a, MonadSnap m) => a -> m () 17 | writeJSON j = do 18 | modifyResponse $ setHeader "Content-Type" "application/json" 19 | writeLBS . encode $ j 20 | 21 | getJSON :: FromJSON a => Handler App App (Either String a) 22 | getJSON = do 23 | bodyVal <- decode `fmap` readRequestBody 50000 24 | return $ case bodyVal of 25 | Nothing -> Left "Invalid JSON data in POST body" 26 | Just v -> case fromJSON v of 27 | Error e -> Left e 28 | Success a -> Right a 29 | 30 | returnJson :: Sqlite.Entity Todo -> Handler App App () 31 | returnJson todo = do 32 | url <- gets appRoot 33 | writeJSON $ mkTodoResponse url todo 34 | 35 | jsonList :: [Sqlite.Entity Todo] -> Handler App App () 36 | jsonList todos = do 37 | url <- gets appRoot 38 | writeJSON $ map (mkTodoResponse url) todos 39 | 40 | appInit :: SnapletInit App App 41 | appInit = makeSnaplet "todoapp" "Todobackend example" Nothing $ do 42 | addRoutes [ ("todos", optionsResp) 43 | , ("todos", todosHandler) 44 | , ("todos/:todoid", optionsResp) 45 | , ("todos/:todoid", todoHandler) 46 | ] 47 | url <- liftIO $ getEnv "URL" 48 | return $ App url 49 | 50 | allowCors :: Handler App App () 51 | allowCors = mapM_ (modifyResponse . uncurry setHeader) [ 52 | ("Access-Control-Allow-Origin", "*"), 53 | ("Access-Control-Allow-Headers", "Accept, Content-Type"), 54 | ("Access-Control-Allow-Methods", "GET, HEAD, POST, DELETE, OPTIONS, PUT, PATCH") 55 | ] 56 | 57 | optionsResp :: Handler App App () 58 | optionsResp = method OPTIONS allowCors 59 | 60 | 61 | todosHandler :: Handler App App () 62 | todosHandler = do 63 | allowCors 64 | req <- getRequest 65 | case rqMethod req of 66 | GET -> do 67 | todos <- liftIO $ runDb $ 68 | Sqlite.selectList [] ([] :: [Sqlite.SelectOpt Todo]) 69 | jsonList todos 70 | POST -> do 71 | todoActE <- getJSON 72 | case todoActE of 73 | Right todoAct -> do 74 | let todo = actionToTodo todoAct 75 | tid <- liftIO $ runDb $ Sqlite.insert todo 76 | returnJson $ Sqlite.Entity tid todo 77 | Left _ -> writeBS "error" 78 | DELETE -> liftIO $ runDb $ Sqlite.deleteWhere ([] :: [Sqlite.Filter Todo]) 79 | _ -> writeBS "error" 80 | 81 | todoHandler :: Handler App App () 82 | todoHandler = do 83 | allowCors 84 | Just tidBS <- getParam "todoid" 85 | req <- getRequest 86 | case C8.readInteger tidBS of 87 | Nothing -> writeBS "error" 88 | Just (n, _) -> do 89 | let tid = Sqlite.toSqlKey $ fromIntegral n 90 | case rqMethod req of 91 | GET -> do 92 | Just todo <- liftIO $ runDb $ Sqlite.get tid 93 | returnJson $ Sqlite.Entity tid todo 94 | PATCH -> do 95 | todoActE <- getJSON 96 | case todoActE of 97 | Left _ -> writeBS "error" 98 | Right todoAct -> do 99 | let todoUp = actionToUpdates todoAct 100 | todo <- liftIO $ runDb $ Sqlite.updateGet tid todoUp 101 | returnJson $ Sqlite.Entity tid todo 102 | DELETE -> liftIO $ runDb $ Sqlite.delete tid 103 | _ -> undefined 104 | 105 | main :: IO () 106 | main = do 107 | runDb $ Sqlite.runMigration migrateAll 108 | port <- read <$> getEnv "PORT" 109 | let config = setPort port defaultConfig 110 | serveSnaplet config appInit 111 | -------------------------------------------------------------------------------- /todobackend-snap/todobackend-snap.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-snap 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Snap 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-snap 16 | main-is: Main.hs 17 | ghc-options: -Wall 18 | -- other-modules: 19 | -- other-extensions: 20 | build-depends: base >=4.6 && <5 21 | , aeson 22 | , bytestring 23 | , mtl 24 | , persistent-sqlite 25 | , snap 26 | , todobackend-common 27 | , transformers 28 | 29 | hs-source-dirs: src 30 | default-language: Haskell2010 -------------------------------------------------------------------------------- /todobackend-spock/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-spock/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-spock/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Control.Monad.IO.Class (liftIO) 3 | import qualified Database.Persist.Sqlite as Sqlite 4 | import Network.HTTP.Types.Status (status404) 5 | import System.Environment 6 | import Web.Spock.Core 7 | import Web.PathPieces 8 | 9 | import TodoBackend.Model 10 | import TodoBackend.Utils 11 | 12 | json' :: String -> Sqlite.Entity Todo -> ActionT IO () 13 | json' url = json . mkTodoResponse url 14 | 15 | jsonList :: String -> [Sqlite.Entity Todo] -> ActionT IO () 16 | jsonList url = json . map (mkTodoResponse url) 17 | 18 | main :: IO () 19 | main = do 20 | runDb $ Sqlite.runMigration migrateAll 21 | port <- read <$> getEnv "PORT" 22 | url <- getEnv "URL" 23 | runSpock port $ spockT id $ do 24 | middleware allowCors 25 | middleware allowOptions 26 | get (sub root) $ do 27 | todos <- liftIO $ runDb $ Sqlite.selectList [] ([] :: [Sqlite.SelectOpt Todo]) 28 | jsonList url todos 29 | get (sub var) $ \tid -> actionOr404 tid (\ident -> do 30 | mtodo <- liftIO $ runDb $ Sqlite.get 31 | (ident :: TodoId) 32 | case mtodo of 33 | Nothing -> setStatus status404 34 | Just todo -> json' url (Sqlite.Entity ident todo)) 35 | patch (sub var) $ \tid -> actionOr404 tid (\ident -> do 36 | todoAct <- jsonBody' 37 | let todoUp = actionToUpdates todoAct 38 | todo <- liftIO $ runDb $ Sqlite.updateGet 39 | ident todoUp 40 | json' url (Sqlite.Entity ident todo)) 41 | delete (sub var) $ \tid -> actionOr404 tid (\ident -> 42 | liftIO $ runDb $ Sqlite.delete (ident :: TodoId)) 43 | post (sub root) $ do 44 | todoAct <- jsonBody' 45 | let todo = actionToTodo todoAct 46 | tid <- liftIO $ runDb $ Sqlite.insert todo 47 | json' url (Sqlite.Entity tid todo) 48 | delete (sub root) $ liftIO $ runDb $ Sqlite.deleteWhere ([] :: [Sqlite.Filter Todo]) 49 | where 50 | actionOr404 pid action = case fromPathPiece pid of 51 | Nothing -> setStatus status404 52 | Just tid -> action tid 53 | sub = ()"todos" 54 | -------------------------------------------------------------------------------- /todobackend-spock/todobackend-spock.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-spock 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Spock 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-spock 16 | main-is: Main.hs 17 | ghc-options: -Wall 18 | -- other-modules: 19 | -- other-extensions: 20 | build-depends: base >=4.6 && <5 21 | , http-types 22 | , Spock 23 | , Spock-core 24 | , path-pieces 25 | , persistent-sqlite 26 | , todobackend-common 27 | , transformers 28 | 29 | hs-source-dirs: src 30 | default-language: Haskell2010 -------------------------------------------------------------------------------- /todobackend-yesod/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Joel Hermanns 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /todobackend-yesod/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /todobackend-yesod/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | import qualified Database.Persist.Sqlite as Sqlite 7 | import Network.Wai.Handler.Warp (run) 8 | import System.Environment 9 | import Yesod 10 | 11 | import TodoBackend.Model 12 | import TodoBackend.Utils 13 | 14 | 15 | data App = App 16 | { appRoot :: String 17 | } 18 | 19 | mkYesod "App" [parseRoutes| 20 | /todos TodosR GET POST DELETE 21 | /todos/#TodoId TodoR GET PATCH DELETE 22 | |] 23 | 24 | instance Yesod App 25 | 26 | json :: Sqlite.Entity Todo -> Handler Value 27 | json ent = do 28 | App url <- getYesod 29 | returnJson $ mkTodoResponse url ent 30 | 31 | jsonList :: [Sqlite.Entity Todo] -> Handler Value 32 | jsonList ents = do 33 | App url <- getYesod 34 | returnJson $ map (mkTodoResponse url) ents 35 | 36 | getTodosR :: Handler Value 37 | getTodosR = do 38 | todos <- liftIO $ runDb $ Sqlite.selectList [] ([] :: [Sqlite.SelectOpt Todo]) 39 | jsonList todos 40 | 41 | postTodosR :: Handler Value 42 | postTodosR = do 43 | todoAct <- requireCheckJsonBody 44 | let todo = actionToTodo todoAct 45 | tid <- liftIO $ runDb $ Sqlite.insert todo 46 | json $ Sqlite.Entity tid todo 47 | 48 | deleteTodosR :: Handler () 49 | deleteTodosR = do 50 | liftIO $ runDb $ Sqlite.deleteWhere ( [] :: [Sqlite.Filter Todo]) 51 | return () 52 | 53 | getTodoR :: TodoId -> Handler Value 54 | getTodoR tid = do 55 | todo <- liftIO $ runDb $ get404 tid 56 | json $ Sqlite.Entity tid todo 57 | 58 | patchTodoR :: TodoId -> Handler Value 59 | patchTodoR tid = do 60 | todoAct <- requireCheckJsonBody 61 | let todoUp = actionToUpdates todoAct 62 | todo <- liftIO $ runDb $ Sqlite.updateGet tid todoUp 63 | json $ Sqlite.Entity tid todo 64 | 65 | deleteTodoR :: TodoId -> Handler () 66 | deleteTodoR tid = do 67 | liftIO $ runDb $ Sqlite.delete tid 68 | return () 69 | 70 | mkApp :: Application -> Application 71 | mkApp a = allowCors $ allowOptions a 72 | 73 | main :: IO () 74 | main = do 75 | runDb $ Sqlite.runMigration migrateAll 76 | port <- read <$> getEnv "PORT" 77 | url <- getEnv "URL" 78 | waiApp <- toWaiApp $ App url 79 | run port $ mkApp waiApp 80 | -------------------------------------------------------------------------------- /todobackend-yesod/todobackend-yesod.cabal: -------------------------------------------------------------------------------- 1 | name: todobackend-yesod 2 | version: 0.1.0.0 3 | synopsis: Todobackend implementation using Yesod 4 | description: Please see README.md 5 | license: MIT 6 | license-file: LICENSE 7 | author: Joel Hermanns 8 | maintainer: joel.hermanns@gmail.com 9 | -- copyright: 10 | category: Web 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | executable todobackend-yesod 16 | main-is: Main.hs 17 | -- other-modules: 18 | -- other-extensions: 19 | build-depends: base >=4.6 && < 5 20 | , persistent-sqlite 21 | , todobackend-common 22 | , transformers 23 | , wai 24 | , warp 25 | , yesod 26 | hs-source-dirs: src 27 | default-language: Haskell2010 28 | --------------------------------------------------------------------------------