hairy (empty) → 0.1.0

raw patch · 11 files changed

+530/−0 lines, 11 filesdep +aesondep +basedep +criterionsetup-changed

Dependencies added: aeson, base, criterion, data-default, hairy, hspec, http-types, monad-logger, mtl, persistent, persistent-postgresql, persistent-template, scotty, text, time, transformers, wai, wai-extra, warp

Files

• CHANGELOG.md +1/−0
• CONTRIBUTING.md +7/−0
• LICENSE.md +18/−0
• README.md +3/−0
• Setup.hs +8/−0
• benchmark/Main.hs +81/−0
• executable/Main.hs +5/−0
• hairy.cabal +96/−0
• library/Hairy.lhs +180/−0
• library/Hairy/Models.hs +20/−0
• test-suite/Main.hs +111/−0

@@ -0,0 +1,1 @@+# Changelog

@@ -0,0 +1,7 @@+# Contributing++1. **Fork** the repository.+2. Create a **branch** for your feature (`git checkout -b feature`).+3. **Commit** your changes (`git commit -a -m 'Feature'`).+4. **Push** to your branch (`git push origin feature`).+5. Create a **pull request**.

@@ -0,0 +1,18 @@+Copyright (c) 2014 Taylor Fausak <taylor@fausak.me>++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,3 @@+# [Hairy][1]++[1]: https://github.com/tfausak/hairy

@@ -0,0 +1,8 @@+module Setup+  ( main+  ) where++import Distribution.Simple (defaultMain)++main :: IO ()+main = defaultMain

@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import Control.Monad.Reader (runReaderT)+import Criterion (bench, bgroup, whnfIO)+import Criterion.Main (defaultMain)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (UTCTime), utctDay, utctDayTime)+import Database.Persist.Sql (ConnectionPool, insert_, rawExecute, runSqlPool)+import Hairy (Config (Config), Environment (Test), application, pool,+  environment, getPool, runConfigM)+import Hairy.Models (Task (Task), taskContent, taskCreated)+import Network.HTTP.Types.Status (created201, notFound404, ok200)+import Network.Wai.Internal (requestMethod)+import Network.Wai.Test (SRequest (SRequest), defaultRequest, request,+  runSession, setPath, simpleBody, simpleHeaders, simpleRequest,+  simpleRequestBody, simpleStatus, srequest)+import Web.Scotty.Trans (scottyAppT)++main :: IO ()+main = do+  let e = Test+  p <- getPool e+  let c = Config+        { environment = e+        , pool = p+        }+      t m = runReaderT (runConfigM m) c+  a <- scottyAppT t t application++  resetDB p+  createTask p++  defaultMain+    [ bgroup "/"+      [ bench "GET" $ whnfIO $ do+        runSession (request defaultRequest) a+      ]+    , bgroup "/tasks"+      [ bench "GET" $ whnfIO $ do+        runSession (request (defaultRequest `setPath` "/tasks")) a+      , bench "POST" $ whnfIO $ do+        flip runSession a $ srequest SRequest+          { simpleRequest = defaultRequest+            { requestMethod = "POST"+            } `setPath` "/tasks"+          , simpleRequestBody = "{\"content\":\"\",\"created\":\"2001-02-03T04:05:06Z\"}"+          }+      ]+    , bgroup "/tasks/:id"+      [ bench "GET" $ whnfIO $ do+        runSession (request (setPath defaultRequest "/tasks/1")) a+      , bench "PUT" $ whnfIO $ do+        flip runSession a $ srequest SRequest+          { simpleRequest = defaultRequest+            { requestMethod = "PUT"+            } `setPath` "/tasks/1"+          , simpleRequestBody = "{\"content\":\"\",\"created\":\"2001-02-03T04:05:06Z\"}"+          }+      , bench "DELETE" $ whnfIO $ do+        flip runSession a $ request $ defaultRequest+          { requestMethod = "DELETE"+          } `setPath` "/tasks/1"+      ]+    ]++resetDB :: ConnectionPool -> IO ()+resetDB = runSqlPool (rawExecute "TRUNCATE TABLE task RESTART IDENTITY" [])++createTask :: ConnectionPool -> IO ()+createTask = runSqlPool (insert_ task) where+  task = Task+    { taskContent = ""+    , taskCreated = UTCTime+      { utctDay = fromGregorian 2001 2 3+      , utctDayTime = 14706+      }+    }

@@ -0,0 +1,5 @@+module Main+  ( main+  ) where++import Hairy (main)

@@ -0,0 +1,96 @@+name: hairy+version: 0.1.0+cabal-version: >=1.10+build-type: Simple+license: MIT+license-file: LICENSE.md+copyright: 2014 Taylor Fausak <taylor@fausak.me>+maintainer: Taylor Fausak <taylor@fausak.me>+homepage: https://github.com/tfausak/hairy+bug-reports: https://github.com/tfausak/hairy/issues+synopsis: TODO+description:+    TODO+category: Web+author: Taylor Fausak <taylor@fausak.me>+tested-with: GHC ==7.8.*+extra-source-files:+    CHANGELOG.md+    CONTRIBUTING.md+    README.md+ +source-repository head+    type: git+    location: git://github.com/tfausak/hairy.git+ +library+    build-depends:+        base ==4.*,+        aeson ==0.7.*,+        data-default ==0.5.*,+        http-types ==0.8.*,+        mtl ==2.*,+        monad-logger ==0.3.*,+        persistent ==2.*,+        persistent-postgresql ==2.*,+        persistent-template ==2.*,+        scotty ==0.9.*,+        text ==1.*,+        time ==1.*,+        transformers ==0.3.*,+        wai ==3.*,+        wai-extra ==3.*,+        warp ==3.*+    exposed-modules:+        Hairy+        Hairy.Models+    exposed: True+    buildable: True+    default-language: Haskell2010+    hs-source-dirs: library+ +executable hairy+    build-depends:+        base -any,+        hairy -any+    main-is: Main.hs+    buildable: True+    default-language: Haskell2010+    hs-source-dirs: executable+ +test-suite hspec+    build-depends:+        base -any,+        hairy -any,+        hspec ==1.*,+        http-types -any,+        mtl -any,+        persistent -any,+        scotty -any,+        time -any,+        wai -any,+        wai-extra -any+    type: exitcode-stdio-1.0+    main-is: Main.hs+    buildable: True+    default-language: Haskell2010+    hs-source-dirs: test-suite+    ghc-options: -Wall -Werror+ +benchmark criterion+    build-depends:+        base -any,+        hairy -any,+        criterion ==0.8.*,+        http-types -any,+        mtl -any,+        persistent -any,+        scotty -any,+        time -any,+        wai -any,+        wai-extra -any+    type: exitcode-stdio-1.0+    main-is: Main.hs+    buildable: True+    default-language: Haskell2010+    hs-source-dirs: benchmark

@@ -0,0 +1,180 @@+> {-# LANGUAGE FlexibleContexts #-}+> {-# LANGUAGE GeneralizedNewtypeDeriving #-}+> {-# LANGUAGE OverloadedStrings #-}++> module Hairy where++> import Control.Applicative (Applicative)+> import Control.Monad.IO.Class (MonadIO, liftIO)+> import Control.Monad.Logger (runNoLoggingT, runStdoutLoggingT)+> import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)+> import Control.Monad.Trans.Class (MonadTrans, lift)+> import Data.Aeson (Value (Null), (.=), object)+> import Data.Default (def)+> import Data.Text.Lazy (Text)+> import qualified Database.Persist as DB+> import qualified Database.Persist.Postgresql as DB+> import Hairy.Models (Task, TaskId, migrateAll)+> import Network.HTTP.Types.Status (created201, internalServerError500, notFound404)+> import Network.Wai (Middleware)+> import Network.Wai.Handler.Warp (defaultSettings)+> import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)+> import System.Environment (lookupEnv)+> import Web.Scotty.Trans (ActionT, Options, ScottyT, defaultHandler, delete,+>   get, json, jsonData, middleware, notFound, param, post, put, scottyOptsT,+>   settings, showError, status, verbose)++> main :: IO ()+> main = do+>   c <- getConfig+>   runApplication c++> getConfig :: IO Config+> getConfig = do+>   e <- getEnvironment+>   p <- getPool e+>   return Config+>     { environment = e+>     , pool = p+>     }++> data Config = Config+>   { environment :: Environment+>   , pool :: DB.ConnectionPool+>   }++> getEnvironment :: IO Environment+> getEnvironment = do+>   m <- lookupEnv "SCOTTY_ENV"+>   let e = case m of+>         Nothing -> Development+>         Just s -> read s+>   return e++> getPool :: Environment -> IO DB.ConnectionPool+> getPool e =+>   case e of+>     Development -> runStdoutLoggingT (DB.createPostgresqlPool s n)+>     Production -> runStdoutLoggingT (DB.createPostgresqlPool s n)+>     Test -> runNoLoggingT (DB.createPostgresqlPool s n)+>   where+>     s = getConnectionString e+>     n = getConnectionSize e++> getConnectionString :: Environment -> DB.ConnectionString+> getConnectionString Development =+>   "host=localhost port=5432 user=taylor dbname=hairy_development"+> getConnectionString Production =+>   "host=localhost port=5432 user=taylor dbname=hairy_production"+> getConnectionString Test =+>   "host=localhost port=5432 user=taylor dbname=hairy_test"++> getConnectionSize :: Environment -> Int+> getConnectionSize Development = 1+> getConnectionSize Production = 8+> getConnectionSize Test = 1++> data Environment+>   = Development+>   | Production+>   | Test+>   deriving (Eq, Read, Show)++> runApplication :: Config -> IO ()+> runApplication c = do+>   let o = getOptions (environment c)+>       r m = runReaderT (runConfigM m) c+>   scottyOptsT o r r application++> newtype ConfigM a = ConfigM+>  { runConfigM :: ReaderT Config IO a+>  } deriving (Applicative, Functor, Monad, MonadIO, MonadReader Config)++> getOptions :: Environment -> Options+> getOptions Development = def+> getOptions Production = def+>   { settings = defaultSettings+>   , verbose = 0+>   }+> getOptions Test = def+>   { verbose = 0+>   }++> type Error = Text++> application :: ScottyT Error ConfigM ()+> application = do+>   runDB (DB.runMigration migrateAll)++>   e <- lift (asks environment)+>   middleware (loggingM e)+>   defaultHandler (defaultH e)++>   get "/tasks" getTasksA+>   post "/tasks" postTasksA+>   get "/tasks/:id" getTaskA+>   put "/tasks/:id" putTaskA+>   delete "/tasks/:id" deleteTaskA++>   notFound notFoundA++> runDB :: (MonadTrans t, MonadIO (t ConfigM)) => DB.SqlPersistT IO a -> t ConfigM a+> runDB q = do+>   p <- lift (asks pool)+>   liftIO (DB.runSqlPool q p)++> loggingM :: Environment -> Middleware+> loggingM Development = logStdoutDev+> loggingM Production = logStdout+> loggingM Test = id++> type Action = ActionT Error ConfigM ()++> defaultH :: Environment -> Error -> Action+> defaultH e x = do+>   status internalServerError500+>   case e of+>     Development -> json (object ["error" .= showError x])+>     Production -> json Null+>     Test -> json (object ["error" .= showError x])++> getTasksA :: Action+> getTasksA = do+>   ts <- runDB (DB.selectList [] [])+>   json (ts :: [DB.Entity Task])++> postTasksA :: Action+> postTasksA = do+>   t <- jsonData+>   runDB (DB.insert_ t)+>   status created201+>   json (t :: Task)++> getTaskA :: Action+> getTaskA = do+>   i <- param "id"+>   m <- runDB (DB.get (toKey i))+>   case m of+>     Nothing -> notFoundA+>     Just t -> json (t :: Task)++> putTaskA :: Action+> putTaskA = do+>   i <- param "id"+>   t <- jsonData+>   runDB (DB.repsert (toKey i) t)+>   json (t :: Task)++> deleteTaskA :: Action+> deleteTaskA = do+>   i <- param "id"+>   runDB (DB.delete (toKey i :: TaskId))+>   json Null++> toKey :: DB.ToBackendKey DB.SqlBackend a => Integer -> DB.Key a+> toKey i = DB.toSqlKey (fromIntegral (i :: Integer))++> notFoundA :: Action+> notFoundA = do+>   status notFound404+>   json Null

@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Hairy.Models where++import Data.Text (Text)+import Data.Time.Clock (UTCTime)+import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, share,+  sqlSettings)++share [mkMigrate "migrateAll", mkPersist sqlSettings] [persistLowerCase|+Task json+  content Text+  created UTCTime default=now()+|]

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}++module Main+  ( main+  ) where++import Control.Monad.Reader (runReaderT)+import Hairy (Config (Config), Environment (Test), application, pool,+  environment, getPool, runConfigM)+import Hairy.Models (Task (Task), taskContent, taskCreated)+import Data.Time.Calendar (fromGregorian)+import Data.Time.Clock (UTCTime (UTCTime), utctDay, utctDayTime)+import Database.Persist.Sql (ConnectionPool, insert_, rawExecute, runSqlPool)+import Network.HTTP.Types.Status (created201, notFound404, ok200)+import Network.Wai.Internal (requestMethod)+import Network.Wai.Test (SRequest (SRequest), defaultRequest, request,+  runSession, setPath, simpleBody, simpleHeaders, simpleRequest,+  simpleRequestBody, simpleStatus, srequest)+import Test.Hspec (before, describe, hspec, it, shouldBe)+import Web.Scotty.Trans (scottyAppT)++main :: IO ()+main = do+  let e = Test+  p <- getPool e+  let c = Config+        { environment = e+        , pool = p+        }+      t m = runReaderT (runConfigM m) c+  a <- scottyAppT t t application++  hspec $ before (resetDB p) $ do+    describe "/" $ do+      describe "GET" $ do+        it "404s" $ do+          r <- runSession (request defaultRequest) a+          simpleStatus r `shouldBe` notFound404+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe` "null"++    describe "/tasks" $ do+      describe "GET" $ do+        it "lists the tasks" $ do+          r <- runSession (request (defaultRequest `setPath` "/tasks")) a+          simpleStatus r `shouldBe` ok200+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe` "[]"++      describe "POST" $ do+        it "creates a task" $ do+          let req = srequest SRequest+                { simpleRequest = defaultRequest+                  { requestMethod = "POST"+                  } `setPath` "/tasks"+                , simpleRequestBody = "{\"content\":\"\",\"created\":\"2001-02-03T04:05:06Z\"}"+                }+          r <- runSession req a+          simpleStatus r `shouldBe` created201+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe`+            "{\"created\":\"2001-02-03T04:05:06.000Z\",\"content\":\"\"}"++    describe "/tasks/:id" $ before (createTask p) $ do+      describe "GET" $ do+        it "shows the task" $ do+          r <- runSession (request (setPath defaultRequest "/tasks/1")) a+          simpleStatus r `shouldBe` ok200+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe`+            "{\"created\":\"2001-02-03T04:05:06.000Z\",\"content\":\"\"}"++      describe "PUT" $ do+        it "replaces the task" $ do+          let req = srequest SRequest+                { simpleRequest = defaultRequest+                  { requestMethod = "PUT"+                  } `setPath` "/tasks/1"+                , simpleRequestBody = "{\"content\":\"!\",\"created\":\"2001-02-03T04:05:06Z\"}"+                }+          r <- runSession req a+          simpleStatus r `shouldBe` ok200+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe`+            "{\"created\":\"2001-02-03T04:05:06.000Z\",\"content\":\"!\"}"++      describe "DELETE" $ do+        it "deletes the task" $ do+          r <- runSession (request (defaultRequest { requestMethod = "DELETE" }`setPath` "/tasks/1")) a+          simpleStatus r `shouldBe` ok200+          lookup "Content-Type" (simpleHeaders r) `shouldBe`+            Just "application/json; charset=utf-8"+          simpleBody r `shouldBe` "null"++resetDB :: ConnectionPool -> IO ()+resetDB = runSqlPool (rawExecute "TRUNCATE TABLE task RESTART IDENTITY" [])++createTask :: ConnectionPool -> IO ()+createTask = runSqlPool (insert_ task) where+  task = Task+    { taskContent = ""+    , taskCreated = UTCTime+      { utctDay = fromGregorian 2001 2 3+      , utctDayTime = 14706+      }+    }