wai-handler-devel/FullApp.hs · typeable/wai

git.iko.soy/typeable/wai

on wai-extra/2.0.1.2 help sign in

47 lines 1.9 kB history raw

1{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, GADTs #-}

2{-# LANGUAGE TemplateHaskell #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE FlexibleContexts #-}

5module FullApp (fullApp) where

7import Network.Wai

8import Network.HTTP.Types

9import Data.ByteString.Lazy.Char8 (pack)

10import Database.Persist.TH

11import Database.Persist.Sqlite

12import System.Directory

13import Control.Monad (when)

14import Text.Hamlet

15import Text.Blaze.Html.Renderer.Utf8 (renderHtml)

16import Data.Text.Lazy.Encoding (encodeUtf16LE)

17import Control.Monad.Trans.Resource (runResourceT)

18import Control.Monad.IO.Class (liftIO)

20share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|

21Dummy

22 dummy String

25fullApp :: (Application -> IO ()) -> IO ()

26fullApp handler = do

27 putStrLn "testApp called, this should happen only once per reload"

28 -- Swap between the following two lines as necessary to generate errors

29 exi <- doesFileExist "db"

30 --let exi = True

31 when exi $ removeFile "db"

32 withSqlitePool "db" 10 $ \pool -> do

33 flip runSqlPool pool $ runMigration migrateAll

34 handler $ \req -> do

35 if pathInfo req == ["favicon.ico"]

36 then return $ responseLBS status301 [("Location", "http://www.yesodweb.com/favicon.ico")]

37 $ pack ""

38 else do

39 liftIO $ print (pathInfo req)

40 x <- runResourceT $ flip runSqlPool pool $ do

41 _ <- insert (Dummy "")

42 count ([] :: [Filter Dummy])

43 return $ responseLBS status200

44 [("Content-Type", "text/html; charset=utf-8")] $

45 renderHtml

46 $(shamletFile "hamlet/testapp.hamlet")

47 putStrLn "handler completed, this should only happen at the beginning of a reload"