gingersnap-0.3.1.0: test/Tests.hs

{-# LANGUAGE
     InstanceSigs
   , OverloadedStrings
   , TypeFamilies, NoMonoLocalBinds
   #-}

module Main where

import Control.Applicative -- For GHC 7.8

import qualified Data.Map as Map
import Database.PostgreSQL.Simple.Transaction as PSQL
import Snap.Core
import Snap.Test
import Test.Microspec

import Gingersnap.Core


main :: IO ()
main = microspec $ do
   describe "read-only mode" $ do
      let rwHandler, rHandler :: (IsCtx ctx, TxModeType ctx ~ PSQL.TransactionMode) => ctx -> Snap ()
          rwHandler ctx = inTransaction_readWrite ctx $ \_ -> pure $ rspGood True
          rHandler  ctx = inTransaction_readOnly  ctx $ \_ -> pure $ rspGood True
      it "doesn't run a read-write tx in read-only  mode" $ monadicIO $ do
         ctx <- run mkReadOnlyCtx
         r <- run $ runHandler (get "" Map.empty) (rwHandler ctx)
         body <- run $ getResponseBody r
         assert $ (rspStatus r == 503) && (body == "{\"errorCode\":0,\"errorVals\":[],\"errorMessage\":\"This action is unavailable in read-only mode\"}")
      it "does    run a read-write tx in read-write mode" $ monadicIO $ do
         ctx <- run mkReadWriteCtx
         r <- run $ runHandler (get "" Map.empty) (rwHandler ctx)
         body <- run $ getResponseBody r
         assert $ (rspStatus r == 200) && (body == "{\"result\":true}")
      it "does    run a read-only  tx in read-only mode" $ monadicIO $ do
         ctx <- run mkReadOnlyCtx
         r <- run $ runHandler (get "" Map.empty) (rHandler ctx)
         body <- run $ getResponseBody r
         assert $ (rspStatus r == 200) && (body == "{\"result\":true}")

data ReadOnlyCtx
   = ReadOnlyCtx (Pool ())

mkReadOnlyCtx :: IO ReadOnlyCtx
mkReadOnlyCtx = ReadOnlyCtx <$> createPool (pure ()) (\() -> pure ()) 100 0.5 100

data ReadWriteCtx
   = ReadWriteCtx (Pool ())

mkReadWriteCtx :: IO ReadWriteCtx
mkReadWriteCtx = ReadWriteCtx <$> createPool (pure ()) (\() -> pure ()) 100 0.5 100

instance IsCtx ReadOnlyCtx where
   ctxGetReadOnlyMode _ = pure True
   ctxConnectionPool (ReadOnlyCtx p) = p

   type ConnType ReadOnlyCtx = ()
   ctx_beginTransaction :: ReadOnlyCtx -> PSQL.TransactionMode -> () -> IO ()
   ctx_beginTransaction _ _ _ = pure ()
   ctx_commit :: ReadOnlyCtx -> () -> IO ()
   ctx_commit _ _ = pure ()
   ctx_rollback :: ReadOnlyCtx -> () -> IO ()
   ctx_rollback _ _ = pure ()

instance IsCtx ReadWriteCtx where
   ctxGetReadOnlyMode _ = pure False
   ctxConnectionPool (ReadWriteCtx p) = p

   type ConnType ReadWriteCtx = ()
   ctx_beginTransaction :: ReadWriteCtx -> PSQL.TransactionMode -> () -> IO ()
   ctx_beginTransaction _ _ _ = pure ()
   ctx_commit :: ReadWriteCtx -> () -> IO ()
   ctx_commit _ _ = pure ()
   ctx_rollback :: ReadWriteCtx -> () -> IO ()
   ctx_rollback _ _ = pure ()