{- |
Module      : Control.Monad.Script.Http
Description : A generic monad for expressing HTTP interactions.
Copyright   : 2018, Automattic, Inc.
License     : BSD3
Maintainer  : Nathan Bloomfield (nbloomf@gmail.com)
Stability   : experimental
Portability : POSIX

A basic type and monad transformer transformer for describing HTTP interactions.
-}

{-#
  LANGUAGE
    CPP,
    GADTs,
    Rank2Types,
    RecordWildCards,
    OverloadedStrings,
    QuantifiedConstraints
#-}

module Control.Monad.Script.Http (
  -- * HttpT
    HttpT()

  -- * HttpT
  , HttpTT()
  , execHttpTT
  , liftHttpTT

  -- * Error
  , throwError
  , throwJsonError
  , throwHttpException
  , throwIOException
  , catchError
  , catchJsonError
  , catchHttpException
  , catchIOException
  , catchAnyError
  , printError
  , E(..)

  -- * Reader
  , ask
  , local
  , reader
  , R(..)
  , basicEnv
  , trivialEnv
  , LogOptions(..)
  , basicLogOptions
  , trivialLogOptions

  -- * Writer
  , logEntries
  , LogSeverity(..)
  , setLogSeverity
  , W()
  , printHttpLogs
  , basicLogEntryPrinter

  -- * State
  , gets
  , modify
  , S(..)
  , basicState

  -- * Prompt
  , prompt
  , P(..)
  , evalIO
  , evalMockIO

  -- * API
  , comment
  , wait
  , logDebug
  , logInfo
  , logNotice
  , logWarning
  , logError
  , logCritical
  , logAlert
  , logEmergency

  -- ** IO
  , Control.Monad.Script.Http.hPutStrLn
  , hPutStrLnBlocking

  -- ** HTTP calls
  , httpGet
  , httpSilentGet
  , httpPost
  , httpSilentPost
  , httpDelete
  , httpSilentDelete

  -- ** JSON
  , parseJson
  , lookupKeyJson
  , constructFromJson

  -- * Types
  , Url
  , JsonError(..)
  , HttpResponse(..)

  -- * Testing
  , checkHttpTT
) where



#if MIN_VERSION_base(4,9,0)
import Prelude hiding (fail, lookup)
#else
import Prelude hiding (lookup)
#endif

import Control.Applicative
  ( Applicative(..), (<$>) )
import Control.Concurrent
  ( threadDelay )
import Control.Concurrent.MVar
  ( MVar, withMVar )
import Control.Exception
  ( IOException, Exception, try )
import Control.Monad
  ( Functor(..), Monad((>>=),return), ap )
import Control.Monad.Trans.Class
  ( MonadTrans(..) )
import Control.Monad.Trans.Identity
  ( IdentityT(..) )
import Control.Lens
  ( preview, (^.) )
import Data.Aeson
  ( Value(Object), Result(Success,Error), FromJSON, fromJSON, decode )
import Data.Aeson.Encode.Pretty
  ( encodePretty )
import Data.Aeson.Lens
  ( _Value )
import Data.ByteString.Lazy
  ( ByteString, fromStrict, readFile, writeFile, toStrict )
import Data.ByteString.Lazy.Char8
  ( unpack, pack )
import Data.Functor.Identity
  ( Identity() )
import Data.IORef
  ( IORef, newIORef, readIORef, writeIORef )
import Data.List
  ( intercalate )
import Data.String
  ( fromString )
import Data.Text
  ( Text )
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import Data.Time
  ( UTCTime )
import Data.Time.Clock.System
  ( getSystemTime, systemToUTCTime )
import Data.Typeable
  ( Typeable )
import Data.Monoid
  ( Monoid(..) )
import Data.Semigroup
  ( Semigroup(..) )
import Network.HTTP.Client
  ( HttpException(..), CookieJar, HttpExceptionContent(StatusCodeException)
  , Response, responseCookieJar, responseBody
  , responseHeaders, responseVersion, responseStatus )
import Network.HTTP.Types
  ( HttpVersion, Status, ResponseHeaders )
import qualified Network.Wreq as Wreq
  ( Options, getWith, postWith, deleteWith, defaults, responseStatus, headers )
import qualified Network.Wreq.Session as S
  ( Session, newSession, getWith, postWith, deleteWith )
import System.IO
  ( Handle, hPutStrLn, hGetEcho, hSetEcho, hFlush
  , hFlush, hGetLine, hPutStr, hPutChar, stdout )
import System.IO.Error
  ( ioeGetFileName, ioeGetLocation, ioeGetErrorString )
import Test.QuickCheck
  ( Property, Arbitrary(..), Gen, Testable )

import qualified Control.Monad.Script as S
import Network.HTTP.Client.Extras
import Data.Aeson.Extras

-- aeson 2.0.0.0 introduced KeyMap over HashMap
#if MIN_VERSION_aeson(2,0,0)
import Data.Aeson.Key (fromText)
import Data.Aeson.KeyMap (lookup)
#else
import Data.HashMap.Strict (lookup)
#endif

-- Transitional MonadFail implementation
#if MIN_VERSION_base(4,9,0)
import Control.Monad.Fail
#endif

import Data.LogSeverity
import Data.MockIO
import Data.MockIO.FileSystem



-- | An HTTP session returning an @a@, writing to a log of type @W e w@, reading from an environment of type @R e w r@, with state of type @S s@, throwing errors of type @E e@, performing effectful computations described by @P p a@, and with inner monad @t eff@.
newtype HttpTT e r w s p t eff a = HttpTT
  { HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT :: S.ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
  } deriving Typeable

-- | An HTTP session returning an @a@, writing to a log of type @W e w@, reading from an environment of type @R e w r@, with state of type @S s@, throwing errors of type @E e@, performing effectful computations described by @P p a@, with inner monad @eff@. `HttpTT` over `IdentityT`.
type HttpT e r w s p = HttpTT e r w s p IdentityT

instance
  (Monad eff, Monad (t eff), MonadTrans t)
    => Functor (HttpTT e r w s p t eff) where
  fmap :: (a -> b) -> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff b
fmap a -> b
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
-> HttpTT e r w s p t eff b
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
 -> HttpTT e r w s p t eff b)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b)
-> HttpTT e r w s p t eff a
-> HttpTT e r w s p t eff b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

instance
  (Monad eff, Monad (t eff), MonadTrans t)
    => Applicative (HttpTT e r w s p t eff) where
  pure :: a -> HttpTT e r w s p t eff a
pure = a -> HttpTT e r w s p t eff a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: HttpTT e r w s p t eff (a -> b)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff b
(<*>) = HttpTT e r w s p t eff (a -> b)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance
  (Monad eff, Monad (t eff), MonadTrans t)
    => Monad (HttpTT e r w s p t eff) where
  return :: a -> HttpTT e r w s p t eff a
return = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> a
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall (m :: * -> *) a. Monad m => a -> m a
return
  (HttpTT ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
x) >>= :: HttpTT e r w s p t eff a
-> (a -> HttpTT e r w s p t eff b) -> HttpTT e r w s p t eff b
>>= a -> HttpTT e r w s p t eff b
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
-> HttpTT e r w s p t eff b
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
x ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> (a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HttpTT e r w s p t eff b
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT (HttpTT e r w s p t eff b
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b)
-> (a -> HttpTT e r w s p t eff b)
-> a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> HttpTT e r w s p t eff b
f))

instance
  (Monad eff, Monad (t eff), MonadTrans t, MonadFail (t eff))
    => MonadFail (HttpTT e r w s p t eff) where
  fail :: String -> HttpTT e r w s p t eff a
fail = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (String -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> String
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail

instance
  (MonadTrans t, forall m. (Monad m) => Monad (t m))
    => MonadTrans (HttpTT e r w s p t) where
  lift :: m a -> HttpTT e r w s p t m a
lift = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t m a
-> HttpTT e r w s p t m a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t m a
 -> HttpTT e r w s p t m a)
-> (m a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t m a)
-> m a
-> HttpTT e r w s p t m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Lift a value from the inner transformer.
liftHttpTT
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => t eff a -> HttpTT e r w s p t eff a
liftHttpTT :: t eff a -> HttpTT e r w s p t eff a
liftHttpTT = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> t eff a
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t eff a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) a e r s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
t eff a -> ScriptTT e r w s p t eff a
S.liftScriptTT





-- | Execute an `HttpTT` session.
execHttpTT
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => S s -- ^ Initial state
  -> R e w r -- ^ Environment
  -> (forall u. P p u -> eff u) -- ^ Effect evaluator
  -> HttpTT e r w s p t eff a
  -> t eff (Either (E e) a, S s, W e w)
execHttpTT :: S s
-> R e w r
-> (forall u. P p u -> eff u)
-> HttpTT e r w s p t eff a
-> t eff (Either (E e) a, S s, W e w)
execHttpTT S s
s R e w r
r forall u. P p u -> eff u
p = S s
-> R e w r
-> (forall u. P p u -> eff u)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> t eff (Either (E e) a, S s, W e w)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) s r (p :: * -> *)
       e w a.
(Monad eff, Monad (t eff), MonadTrans t) =>
s
-> r
-> (forall u. p u -> eff u)
-> ScriptTT e r w s p t eff a
-> t eff (Either e a, s, w)
S.execScriptTT S s
s R e w r
r forall u. P p u -> eff u
p (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> t eff (Either (E e) a, S s, W e w))
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> t eff (Either (E e) a, S s, W e w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

-- | Turn an `HttpTT` into a property; for testing with QuickCheck.
checkHttpTT
  :: forall eff t q e r w s p a prop
   . (Monad eff, Monad (t eff), MonadTrans t, Show q, Testable prop)
  => S s -- ^ Initial state
  -> R e w r -- ^ Environment
  -> (forall u. P p u -> eff u) -- ^ Effect evaluator
  -> (t eff (Either (E e) a, S s, W e w) -> IO q) -- ^ Condense to `IO`
  -> (q -> prop) -- ^ Result check
  -> HttpTT e r w s p t eff a
  -> Property
checkHttpTT :: S s
-> R e w r
-> (forall u. P p u -> eff u)
-> (t eff (Either (E e) a, S s, W e w) -> IO q)
-> (q -> prop)
-> HttpTT e r w s p t eff a
-> Property
checkHttpTT S s
s R e w r
r forall u. P p u -> eff u
eval t eff (Either (E e) a, S s, W e w) -> IO q
cond q -> prop
check =
  S s
-> R e w r
-> (forall u. P p u -> eff u)
-> (t eff (Either (E e) a, S s, W e w) -> IO q)
-> (q -> prop)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> Property
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) q prop e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t, Show q, Testable prop) =>
s
-> r
-> (forall u. p u -> eff u)
-> (t eff (Either e a, s, w) -> IO q)
-> (q -> prop)
-> ScriptTT e r w s p t eff a
-> Property
S.checkScriptTT S s
s R e w r
r forall u. P p u -> eff u
eval t eff (Either (E e) a, S s, W e w) -> IO q
cond q -> prop
check (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a -> Property)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT



-- | Retrieve the environment.
ask
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff (R e w r)
ask :: HttpTT e r w s p t eff (R e w r)
ask = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff (R e w r)
-> HttpTT e r w s p t eff (R e w r)
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff (R e w r)
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
ScriptTT e r w s p t eff r
S.ask

-- | Run an action with a locally adjusted environment of the same type.
local
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (R e w r -> R e w r)
  -> HttpTT e r w s p t eff a
  -> HttpTT e r w s p t eff a
local :: (R e w r -> R e w r)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff a
local R e w r -> R e w r
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R e w r -> R e w r)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) r e w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
(r -> r)
-> ScriptTT e r w s p t eff a -> ScriptTT e r w s p t eff a
S.local R e w r -> R e w r
f (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

-- | Run an action with a locally adjusted environment of a possibly different type.
transport
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (R e w r2 -> R e w r1)
  -> HttpTT e r1 w s p t eff a
  -> HttpTT e r2 w s p t eff a
transport :: (R e w r2 -> R e w r1)
-> HttpTT e r1 w s p t eff a -> HttpTT e r2 w s p t eff a
transport R e w r2 -> R e w r1
f = ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a
-> HttpTT e r2 w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a
 -> HttpTT e r2 w s p t eff a)
-> (HttpTT e r1 w s p t eff a
    -> ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a)
-> HttpTT e r1 w s p t eff a
-> HttpTT e r2 w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (R e w r2 -> R e w r1)
-> ScriptTT (E e) (R e w r1) (W e w) (S s) (P p) t eff a
-> ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) r2 r1 e w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
(r2 -> r1)
-> ScriptTT e r1 w s p t eff a -> ScriptTT e r2 w s p t eff a
S.transport R e w r2 -> R e w r1
f (ScriptTT (E e) (R e w r1) (W e w) (S s) (P p) t eff a
 -> ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a)
-> (HttpTT e r1 w s p t eff a
    -> ScriptTT (E e) (R e w r1) (W e w) (S s) (P p) t eff a)
-> HttpTT e r1 w s p t eff a
-> ScriptTT (E e) (R e w r2) (W e w) (S s) (P p) t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r1 w s p t eff a
-> ScriptTT (E e) (R e w r1) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

-- | Retrieve the image of the environment under a given function.
reader
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (R e w r -> a)
  -> HttpTT e r w s p t eff a
reader :: (R e w r -> a) -> HttpTT e r w s p t eff a
reader R e w r -> a
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT ((R e w r -> a)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) r a e s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t,
 Monad (t eff)) =>
(r -> a) -> ScriptTT e r w s p t eff a
S.reader R e w r -> a
f)

-- | Retrieve the current state.
get
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff (S s)
get :: HttpTT e r w s p t eff (S s)
get = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff (S s)
-> HttpTT e r w s p t eff (S s)
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff (S s)
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
ScriptTT e r w s p t eff s
S.get

-- | Replace the state.
put
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => S s
  -> HttpTT e r w s p t eff ()
put :: S s -> HttpTT e r w s p t eff ()
put S s
s = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
-> HttpTT e r w s p t eff ()
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (S s -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) s e r
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
s -> ScriptTT e r w s p t eff ()
S.put S s
s)

-- | Modify the current state strictly.
modify
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (S s -> S s)
  -> HttpTT e r w s p t eff ()
modify :: (S s -> S s) -> HttpTT e r w s p t eff ()
modify S s -> S s
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
-> HttpTT e r w s p t eff ()
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT ((S s -> S s)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) s e r
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
(s -> s) -> ScriptTT e r w s p t eff ()
S.modify' S s -> S s
f)

-- | Retrieve the image of the current state under a given function.
gets
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (S s -> a)
  -> HttpTT e r w s p t eff a
gets :: (S s -> a) -> HttpTT e r w s p t eff a
gets S s -> a
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT ((S s -> a) -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) s a e r
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
(s -> a) -> ScriptTT e r w s p t eff a
S.gets S s -> a
f)

-- | Do not export; we want to only allow writes to the log via functions that call @logNow@.
tell
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => W e w
  -> HttpTT e r w s p t eff ()
tell :: W e w -> HttpTT e r w s p t eff ()
tell W e w
w = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
-> HttpTT e r w s p t eff ()
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (W e w -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff ()
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
w -> ScriptTT e r w s p t eff ()
S.tell W e w
w)

-- | Run an action that returns a value and a log-adjusting function, and apply the function to the local log.
pass
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff (a, W e w -> W e w)
  -> HttpTT e r w s p t eff a
pass :: HttpTT e r w s p t eff (a, W e w -> W e w)
-> HttpTT e r w s p t eff a
pass = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (HttpTT e r w s p t eff (a, W e w -> W e w)
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff (a, W e w -> W e w)
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptTT
  (E e) (R e w r) (W e w) (S s) (P p) t eff (a, W e w -> W e w)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *) a.
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
ScriptTT e r w s p t eff (a, w -> w) -> ScriptTT e r w s p t eff a
S.pass (ScriptTT
   (E e) (R e w r) (W e w) (S s) (P p) t eff (a, W e w -> W e w)
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> (HttpTT e r w s p t eff (a, W e w -> W e w)
    -> ScriptTT
         (E e) (R e w r) (W e w) (S s) (P p) t eff (a, W e w -> W e w))
-> HttpTT e r w s p t eff (a, W e w -> W e w)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff (a, W e w -> W e w)
-> ScriptTT
     (E e) (R e w r) (W e w) (S s) (P p) t eff (a, W e w -> W e w)
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

-- | Run an action, applying a function to the local log.
censor
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => (W e w -> W e w)
  -> HttpTT e r w s p t eff a
  -> HttpTT e r w s p t eff a
censor :: (W e w -> W e w)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff a
censor W e w -> W e w
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> HttpTT e r w s p t eff a)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> HttpTT e r w s p t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (W e w -> W e w)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *) a.
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
(w -> w)
-> ScriptTT e r w s p t eff a -> ScriptTT e r w s p t eff a
S.censor W e w -> W e w
f (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> (HttpTT e r w s p t eff a
    -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT

-- | Inject an 'Either' into a 'Script'.
except
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Either (E e) a
  -> HttpTT e r w s p t eff a
except :: Either (E e) a -> HttpTT e r w s p t eff a
except Either (E e) a
e = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (Either (E e) a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e a r s
       (p :: * -> *).
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
Either e a -> ScriptTT e r w s p t eff a
S.except Either (E e) a
e)

-- | Raise an error
throw
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => E e
  -> HttpTT e r w s p t eff a
throw :: E e -> HttpTT e r w s p t eff a
throw E e
e = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (E e -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *) a.
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
e -> ScriptTT e r w s p t eff a
S.throw E e
e)

-- | Run an action, applying a handler in case of an error result.
catch
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a -- ^ Computation that may raise an error
  -> (E e -> HttpTT e r w s p t eff a) -- ^ Handler
  -> HttpTT e r w s p t eff a
catch :: HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x E e -> HttpTT e r w s p t eff a
f = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> (E e -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) e r s
       (p :: * -> *) a.
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
ScriptTT e r w s p t eff a
-> (e -> ScriptTT e r w s p t eff a) -> ScriptTT e r w s p t eff a
S.catch (HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT HttpTT e r w s p t eff a
x) (HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
HttpTT e r w s p t eff a
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
httpTT (HttpTT e r w s p t eff a
 -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a)
-> (E e -> HttpTT e r w s p t eff a)
-> E e
-> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E e -> HttpTT e r w s p t eff a
f))

-- | Inject an atomic effect.
prompt
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => P p a
  -> HttpTT e r w s p t eff a
prompt :: P p a -> HttpTT e r w s p t eff a
prompt P p a
p = ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
forall e r w s (p :: * -> *) (t :: (* -> *) -> * -> *)
       (eff :: * -> *) a.
ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
-> HttpTT e r w s p t eff a
HttpTT (P p a -> ScriptTT (E e) (R e w r) (W e w) (S s) (P p) t eff a
forall w (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a
       e r s.
(Monoid w, Monad eff, Monad (t eff), MonadTrans t) =>
p a -> ScriptTT e r w s p t eff a
S.prompt P p a
p)



-- | Error type.
data E e
  = E_Http HttpException
  | E_IO IOException
  | E_Json JsonError
  | E e -- ^ Client-supplied error type.
  deriving Int -> E e -> ShowS
[E e] -> ShowS
E e -> String
(Int -> E e -> ShowS)
-> (E e -> String) -> ([E e] -> ShowS) -> Show (E e)
forall e. Show e => Int -> E e -> ShowS
forall e. Show e => [E e] -> ShowS
forall e. Show e => E e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [E e] -> ShowS
$cshowList :: forall e. Show e => [E e] -> ShowS
show :: E e -> String
$cshow :: forall e. Show e => E e -> String
showsPrec :: Int -> E e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> E e -> ShowS
Show

-- | Pretty printer for errors
printError :: (e -> Text) -> E e -> Text
printError :: (e -> Text) -> E e -> Text
printError e -> Text
p E e
err = case E e
err of
  E_Http HttpException
e -> [Text] -> Text
T.unlines [ Text
"HTTP Exception:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
e ]
  E_IO IOException
e -> [Text] -> Text
T.unlines [ Text
"IO Exception:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e ]
  E_Json JsonError
e -> [Text] -> Text
T.unlines [ Text
"JSON Error:", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ JsonError -> String
forall a. Show a => a -> String
show JsonError
e ]
  E e
e -> [Text] -> Text
T.unlines [ Text
"Error:", e -> Text
p e
e ]

-- | Also logs the exception.
throwHttpException
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpException
  -> HttpTT e r w s p t eff a
throwHttpException :: HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
e = do
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogError (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ E e -> Log e w
forall e w. E e -> Log e w
errorMessage (E e -> Log e w) -> E e -> Log e w
forall a b. (a -> b) -> a -> b
$ HttpException -> E e
forall e. HttpException -> E e
E_Http HttpException
e
  E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw (E e -> HttpTT e r w s p t eff a)
-> E e -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ HttpException -> E e
forall e. HttpException -> E e
E_Http HttpException
e

-- | Re-throws other error types.
catchHttpException
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a
  -> (HttpException -> HttpTT e r w s p t eff a) -- ^ Handler
  -> HttpTT e r w s p t eff a
catchHttpException :: HttpTT e r w s p t eff a
-> (HttpException -> HttpTT e r w s p t eff a)
-> HttpTT e r w s p t eff a
catchHttpException HttpTT e r w s p t eff a
x HttpException -> HttpTT e r w s p t eff a
handler = HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x ((E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a)
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ \E e
err ->
  case E e
err of
    E_Http HttpException
e -> HttpException -> HttpTT e r w s p t eff a
handler HttpException
e
    E e
_ -> E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw E e
err

-- | Also logs the exception.
throwIOException
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => IOException
  -> HttpTT e r w s p t eff a
throwIOException :: IOException -> HttpTT e r w s p t eff a
throwIOException IOException
e = do
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogError (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ E e -> Log e w
forall e w. E e -> Log e w
errorMessage (E e -> Log e w) -> E e -> Log e w
forall a b. (a -> b) -> a -> b
$ IOException -> E e
forall e. IOException -> E e
E_IO IOException
e
  E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw (E e -> HttpTT e r w s p t eff a)
-> E e -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ IOException -> E e
forall e. IOException -> E e
E_IO IOException
e

-- | Re-throws other error types.
catchIOException
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a
  -> (IOException -> HttpTT e r w s p t eff a) -- ^ Handler
  -> HttpTT e r w s p t eff a
catchIOException :: HttpTT e r w s p t eff a
-> (IOException -> HttpTT e r w s p t eff a)
-> HttpTT e r w s p t eff a
catchIOException HttpTT e r w s p t eff a
x IOException -> HttpTT e r w s p t eff a
handler = HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x ((E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a)
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ \E e
err ->
  case E e
err of
    E_IO IOException
e -> IOException -> HttpTT e r w s p t eff a
handler IOException
e
    E e
_ -> E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw E e
err

-- | Also logs the exception.
throwJsonError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => JsonError
  -> HttpTT e r w s p t eff a
throwJsonError :: JsonError -> HttpTT e r w s p t eff a
throwJsonError JsonError
e = do
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogError (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ E e -> Log e w
forall e w. E e -> Log e w
errorMessage (E e -> Log e w) -> E e -> Log e w
forall a b. (a -> b) -> a -> b
$ JsonError -> E e
forall e. JsonError -> E e
E_Json JsonError
e
  E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw (E e -> HttpTT e r w s p t eff a)
-> E e -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ JsonError -> E e
forall e. JsonError -> E e
E_Json JsonError
e

-- | Re-throws other error types.
catchJsonError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a
  -> (JsonError -> HttpTT e r w s p t eff a) -- ^ Handler
  -> HttpTT e r w s p t eff a
catchJsonError :: HttpTT e r w s p t eff a
-> (JsonError -> HttpTT e r w s p t eff a)
-> HttpTT e r w s p t eff a
catchJsonError HttpTT e r w s p t eff a
x JsonError -> HttpTT e r w s p t eff a
handler = HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x ((E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a)
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ \E e
err ->
  case E e
err of
    E_Json JsonError
e -> JsonError -> HttpTT e r w s p t eff a
handler JsonError
e
    E e
_ -> E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw E e
err

-- | Also logs the exception.
throwError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => e
  -> HttpTT e r w s p t eff a
throwError :: e -> HttpTT e r w s p t eff a
throwError e
e = do
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogError (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ E e -> Log e w
forall e w. E e -> Log e w
errorMessage (E e -> Log e w) -> E e -> Log e w
forall a b. (a -> b) -> a -> b
$ e -> E e
forall e. e -> E e
E e
e
  E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw (E e -> HttpTT e r w s p t eff a)
-> E e -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ e -> E e
forall e. e -> E e
E e
e

-- | Re-throws other error types.
catchError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a
  -> (e -> HttpTT e r w s p t eff a) -- ^ Handler
  -> HttpTT e r w s p t eff a
catchError :: HttpTT e r w s p t eff a
-> (e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catchError HttpTT e r w s p t eff a
x e -> HttpTT e r w s p t eff a
handler = HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x ((E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a)
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ \E e
err ->
  case E e
err of
    E e
e -> e -> HttpTT e r w s p t eff a
handler e
e
    E e
_ -> E e -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
E e -> HttpTT e r w s p t eff a
throw E e
err

-- | Handle any thrown error. To handle only errors of a specific type, see @catchError@, @catchJsonError@, @catchIOException@, or @catchHttpException@.
catchAnyError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => HttpTT e r w s p t eff a
  -> (e -> HttpTT e r w s p t eff a)
  -> (HttpException -> HttpTT e r w s p t eff a)
  -> (IOException -> HttpTT e r w s p t eff a)
  -> (JsonError -> HttpTT e r w s p t eff a)
  -> HttpTT e r w s p t eff a
catchAnyError :: HttpTT e r w s p t eff a
-> (e -> HttpTT e r w s p t eff a)
-> (HttpException -> HttpTT e r w s p t eff a)
-> (IOException -> HttpTT e r w s p t eff a)
-> (JsonError -> HttpTT e r w s p t eff a)
-> HttpTT e r w s p t eff a
catchAnyError HttpTT e r w s p t eff a
x e -> HttpTT e r w s p t eff a
hE HttpException -> HttpTT e r w s p t eff a
hHttp IOException -> HttpTT e r w s p t eff a
hIO JsonError -> HttpTT e r w s p t eff a
hJson =
  HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff a
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
catch HttpTT e r w s p t eff a
x ((E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a)
-> (E e -> HttpTT e r w s p t eff a) -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ \E e
err -> case E e
err of
    E e
e -> e -> HttpTT e r w s p t eff a
hE e
e
    E_Http HttpException
e -> HttpException -> HttpTT e r w s p t eff a
hHttp HttpException
e
    E_IO IOException
e -> IOException -> HttpTT e r w s p t eff a
hIO IOException
e
    E_Json JsonError
e -> JsonError -> HttpTT e r w s p t eff a
hJson JsonError
e



-- | Generic session environment.
data R e w r = R
  { R e w r -> LogOptions e w
_logOptions :: LogOptions e w

  -- | Printer for log entries.
  , R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text

  -- | Handle for printing logs
  , R e w r -> Handle
_logHandle :: Handle

  -- | Lock used to prevent race conditions when writing to the log.
  , R e w r -> Maybe (MVar ())
_logLock :: Maybe (MVar ())

  -- | Identifier string for the session; used to help match log entries emitted by the same session.
  , R e w r -> Text
_uid :: Text

  -- | Function for elevating 'HttpException's to a client-supplied error type.
  , R e w r -> HttpException -> Maybe e
_httpErrorInject :: HttpException -> Maybe e 

  -- | Client-supplied environment type.
  , R e w r -> r
_env :: r
  }

-- | Environment constructor
basicEnv
  :: (Show e, Show w)
  => r -- ^ Client-supplied environment value.
  -> R e w r
basicEnv :: r -> R e w r
basicEnv r
r = R :: forall e w r.
LogOptions e w
-> (LogOptions e w -> LogEntry e w -> Maybe Text)
-> Handle
-> Maybe (MVar ())
-> Text
-> (HttpException -> Maybe e)
-> r
-> R e w r
R
  { _httpErrorInject :: HttpException -> Maybe e
_httpErrorInject = Maybe e -> HttpException -> Maybe e
forall a b. a -> b -> a
const Maybe e
forall a. Maybe a
Nothing
  , _logOptions :: LogOptions e w
_logOptions = LogOptions e w
forall e w. (Show e, Show w) => LogOptions e w
basicLogOptions
  , _logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logEntryPrinter = LogOptions e w -> LogEntry e w -> Maybe Text
forall e w. LogOptions e w -> LogEntry e w -> Maybe Text
basicLogEntryPrinter
  , _logHandle :: Handle
_logHandle = Handle
stdout
  , _logLock :: Maybe (MVar ())
_logLock = Maybe (MVar ())
forall a. Maybe a
Nothing
  , _uid :: Text
_uid = Text
""
  , _env :: r
_env = r
r
  }

-- | Environment constructor
trivialEnv
  :: r -- ^ Client-supplied environment value.
  -> R e w r
trivialEnv :: r -> R e w r
trivialEnv r
r = R :: forall e w r.
LogOptions e w
-> (LogOptions e w -> LogEntry e w -> Maybe Text)
-> Handle
-> Maybe (MVar ())
-> Text
-> (HttpException -> Maybe e)
-> r
-> R e w r
R
  { _httpErrorInject :: HttpException -> Maybe e
_httpErrorInject = Maybe e -> HttpException -> Maybe e
forall a b. a -> b -> a
const Maybe e
forall a. Maybe a
Nothing
  , _logOptions :: LogOptions e w
_logOptions = LogOptions e w
forall e w. LogOptions e w
trivialLogOptions
  , _logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logEntryPrinter = LogOptions e w -> LogEntry e w -> Maybe Text
forall e w. LogOptions e w -> LogEntry e w -> Maybe Text
basicLogEntryPrinter
  , _logHandle :: Handle
_logHandle = Handle
stdout
  , _logLock :: Maybe (MVar ())
_logLock = Maybe (MVar ())
forall a. Maybe a
Nothing
  , _uid :: Text
_uid = Text
""
  , _env :: r
_env = r
r
  }

-- | Options for tweaking the logs.
data LogOptions e w = LogOptions
  { -- | Toggle color
    LogOptions e w -> Bool
_logColor :: Bool

    -- | Toggle JSON pretty printing
  , LogOptions e w -> Bool
_logJson :: Bool

    -- | Toggle to silence the logs
  , LogOptions e w -> Bool
_logSilent :: Bool

    -- | Suppress log output below this severity
  , LogOptions e w -> LogSeverity
_logMinSeverity :: LogSeverity

    -- | Toggle for printing HTTP headers
  , LogOptions e w -> Bool
_logHeaders :: Bool

    -- | Printer for client-supplied error type. The boolean toggles JSON pretty printing.
  , LogOptions e w -> Bool -> e -> Text
_printUserError :: Bool -> e -> Text

    -- | Printer for client-supplied log type. the boolean toggles JSON pretty printing.
  , LogOptions e w -> Bool -> w -> Text
_printUserLog :: Bool -> w -> Text
  }

-- | Noisy, in color, without parsing JSON responses, and using `Show` instances for user-supplied error and log types.
basicLogOptions :: (Show e, Show w) => LogOptions e w
basicLogOptions :: LogOptions e w
basicLogOptions = LogOptions :: forall e w.
Bool
-> Bool
-> Bool
-> LogSeverity
-> Bool
-> (Bool -> e -> Text)
-> (Bool -> w -> Text)
-> LogOptions e w
LogOptions
  { _logColor :: Bool
_logColor = Bool
True
  , _logJson :: Bool
_logJson = Bool
False
  , _logSilent :: Bool
_logSilent = Bool
False
  , _logMinSeverity :: LogSeverity
_logMinSeverity = LogSeverity
LogDebug
  , _logHeaders :: Bool
_logHeaders = Bool
True
  , _printUserError :: Bool -> e -> Text
_printUserError = \Bool
_ e
e -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e
  , _printUserLog :: Bool -> w -> Text
_printUserLog = \Bool
_ w
w -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ w -> String
forall a. Show a => a -> String
show w
w
  }

-- | Noisy, in color, without parsing JSON responses, and using trivial printers for user-supplied error and log types. For testing.
trivialLogOptions :: LogOptions e w
trivialLogOptions :: LogOptions e w
trivialLogOptions = LogOptions :: forall e w.
Bool
-> Bool
-> Bool
-> LogSeverity
-> Bool
-> (Bool -> e -> Text)
-> (Bool -> w -> Text)
-> LogOptions e w
LogOptions
  { _logColor :: Bool
_logColor = Bool
True
  , _logJson :: Bool
_logJson = Bool
False
  , _logSilent :: Bool
_logSilent = Bool
False
  , _logMinSeverity :: LogSeverity
_logMinSeverity = LogSeverity
LogDebug
  , _logHeaders :: Bool
_logHeaders = Bool
True
  , _printUserError :: Bool -> e -> Text
_printUserError = \Bool
_ e
_ -> Text
"ERROR"
  , _printUserLog :: Bool -> w -> Text
_printUserLog = \Bool
_ w
_ -> Text
"LOG"
  }

-- | Simple default pretty printer for @LogEntry@s.
basicLogEntryPrinter
  :: LogOptions e w
  -> LogEntry e w
  -> Maybe Text
basicLogEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
basicLogEntryPrinter opt :: LogOptions e w
opt@LogOptions{Bool
LogSeverity
Bool -> e -> Text
Bool -> w -> Text
_printUserLog :: Bool -> w -> Text
_printUserError :: Bool -> e -> Text
_logHeaders :: Bool
_logMinSeverity :: LogSeverity
_logSilent :: Bool
_logJson :: Bool
_logColor :: Bool
_printUserLog :: forall e w. LogOptions e w -> Bool -> w -> Text
_printUserError :: forall e w. LogOptions e w -> Bool -> e -> Text
_logHeaders :: forall e w. LogOptions e w -> Bool
_logMinSeverity :: forall e w. LogOptions e w -> LogSeverity
_logSilent :: forall e w. LogOptions e w -> Bool
_logJson :: forall e w. LogOptions e w -> Bool
_logColor :: forall e w. LogOptions e w -> Bool
..} LogEntry{UTCTime
Text
LogSeverity
Log e w
_logEntry :: forall e w. LogEntry e w -> Log e w
_logEntrySeverity :: forall e w. LogEntry e w -> LogSeverity
_logEntryUID :: forall e w. LogEntry e w -> Text
_logEntryTimestamp :: forall e w. LogEntry e w -> UTCTime
_logEntry :: Log e w
_logEntrySeverity :: LogSeverity
_logEntryUID :: Text
_logEntryTimestamp :: UTCTime
..} =
  if Bool
_logSilent Bool -> Bool -> Bool
|| (LogSeverity
_logEntrySeverity LogSeverity -> LogSeverity -> Bool
forall a. Ord a => a -> a -> Bool
< LogSeverity
_logMinSeverity)
    then Maybe Text
forall a. Maybe a
Nothing
    else
      let
        colorize :: Text -> Text
        colorize :: Text -> Text
colorize Text
msg = if Bool
_logColor
          then LogSeverity -> Text -> Text
colorBySeverity LogSeverity
_logEntrySeverity Text
msg
          else Text
msg

        timestamp :: Text
        timestamp :: Text
timestamp = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
19 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
_logEntryTimestamp
      in
        Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"")
          [ Text -> Text
colorize Text
timestamp
          , Text
_logEntryUID
          , Log e w -> Text
forall e w. Log e w -> Text
logEntryTitle Log e w
_logEntry
          , LogOptions e w -> Log e w -> Text
forall e w. LogOptions e w -> Log e w -> Text
logEntryBody LogOptions e w
opt Log e w
_logEntry
          ]



-- | Log type
newtype W e w = W
  { W e w -> [LogEntry e w]
unW :: [LogEntry e w]
  } deriving Int -> W e w -> ShowS
[W e w] -> ShowS
W e w -> String
(Int -> W e w -> ShowS)
-> (W e w -> String) -> ([W e w] -> ShowS) -> Show (W e w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e w. (Show e, Show w) => Int -> W e w -> ShowS
forall e w. (Show e, Show w) => [W e w] -> ShowS
forall e w. (Show e, Show w) => W e w -> String
showList :: [W e w] -> ShowS
$cshowList :: forall e w. (Show e, Show w) => [W e w] -> ShowS
show :: W e w -> String
$cshow :: forall e w. (Show e, Show w) => W e w -> String
showsPrec :: Int -> W e w -> ShowS
$cshowsPrec :: forall e w. (Show e, Show w) => Int -> W e w -> ShowS
Show

instance Semigroup (W e w) where
  (W [LogEntry e w]
a1) <> :: W e w -> W e w -> W e w
<> (W [LogEntry e w]
a2) = [LogEntry e w] -> W e w
forall e w. [LogEntry e w] -> W e w
W ([LogEntry e w]
a1 [LogEntry e w] -> [LogEntry e w] -> [LogEntry e w]
forall a. [a] -> [a] -> [a]
++ [LogEntry e w]
a2)

instance Monoid (W e w) where
  mempty :: W e w
mempty = [LogEntry e w] -> W e w
forall e w. [LogEntry e w] -> W e w
W []
  mappend :: W e w -> W e w -> W e w
mappend = W e w -> W e w -> W e w
forall a. Semigroup a => a -> a -> a
(<>)

data LogEntry e w = LogEntry
  { LogEntry e w -> UTCTime
_logEntryTimestamp :: UTCTime
  , LogEntry e w -> Text
_logEntryUID :: Text
  , LogEntry e w -> LogSeverity
_logEntrySeverity :: LogSeverity
  , LogEntry e w -> Log e w
_logEntry :: Log e w
  } deriving Int -> LogEntry e w -> ShowS
[LogEntry e w] -> ShowS
LogEntry e w -> String
(Int -> LogEntry e w -> ShowS)
-> (LogEntry e w -> String)
-> ([LogEntry e w] -> ShowS)
-> Show (LogEntry e w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e w. (Show e, Show w) => Int -> LogEntry e w -> ShowS
forall e w. (Show e, Show w) => [LogEntry e w] -> ShowS
forall e w. (Show e, Show w) => LogEntry e w -> String
showList :: [LogEntry e w] -> ShowS
$cshowList :: forall e w. (Show e, Show w) => [LogEntry e w] -> ShowS
show :: LogEntry e w -> String
$cshow :: forall e w. (Show e, Show w) => LogEntry e w -> String
showsPrec :: Int -> LogEntry e w -> ShowS
$cshowsPrec :: forall e w. (Show e, Show w) => Int -> LogEntry e w -> ShowS
Show

-- | Log entry type
data Log e w
  = L_Comment Text
  | L_Request HttpVerb Url Wreq.Options (Maybe ByteString)
  | L_SilentRequest
  | L_Response HttpResponse
  | L_SilentResponse
  | L_Pause Int
  | L_HttpError HttpException
  | L_IOError IOException
  | L_JsonError JsonError

  -- | Client-supplied error type
  | L_Error e

  -- | Client-supplied log entry type
  | L_Log w
  deriving Int -> Log e w -> ShowS
[Log e w] -> ShowS
Log e w -> String
(Int -> Log e w -> ShowS)
-> (Log e w -> String) -> ([Log e w] -> ShowS) -> Show (Log e w)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall e w. (Show e, Show w) => Int -> Log e w -> ShowS
forall e w. (Show e, Show w) => [Log e w] -> ShowS
forall e w. (Show e, Show w) => Log e w -> String
showList :: [Log e w] -> ShowS
$cshowList :: forall e w. (Show e, Show w) => [Log e w] -> ShowS
show :: Log e w -> String
$cshow :: forall e w. (Show e, Show w) => Log e w -> String
showsPrec :: Int -> Log e w -> ShowS
$cshowsPrec :: forall e w. (Show e, Show w) => Int -> Log e w -> ShowS
Show

logEntryTitle :: Log e w -> LogEntryTitle
logEntryTitle :: Log e w -> Text
logEntryTitle Log e w
e = case Log e w
e of
  L_Comment Text
_ -> Text
"Comment"
  L_Request HttpVerb
_ Text
_ Options
_ Maybe ByteString
_ -> Text
"Request"
  Log e w
L_SilentRequest -> Text
"Silent Request"
  L_Response HttpResponse
_ -> Text
"Response"
  Log e w
L_SilentResponse -> Text
"Silent Response"
  L_Pause Int
_ -> Text
"Pause"
  L_HttpError HttpException
_ -> Text
"HTTP Exception"
  L_IOError IOException
_ -> Text
"IO Exception"
  L_JsonError JsonError
_ -> Text
"JSON Error"
  L_Error e
_ -> Text
"Error"
  L_Log w
_ -> Text
"Log"

-- | Used in the logs.
data HttpVerb
  = DELETE | GET | POST
  deriving (HttpVerb -> HttpVerb -> Bool
(HttpVerb -> HttpVerb -> Bool)
-> (HttpVerb -> HttpVerb -> Bool) -> Eq HttpVerb
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HttpVerb -> HttpVerb -> Bool
$c/= :: HttpVerb -> HttpVerb -> Bool
== :: HttpVerb -> HttpVerb -> Bool
$c== :: HttpVerb -> HttpVerb -> Bool
Eq, Int -> HttpVerb -> ShowS
[HttpVerb] -> ShowS
HttpVerb -> String
(Int -> HttpVerb -> ShowS)
-> (HttpVerb -> String) -> ([HttpVerb] -> ShowS) -> Show HttpVerb
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HttpVerb] -> ShowS
$cshowList :: [HttpVerb] -> ShowS
show :: HttpVerb -> String
$cshow :: HttpVerb -> String
showsPrec :: Int -> HttpVerb -> ShowS
$cshowsPrec :: Int -> HttpVerb -> ShowS
Show)

-- | All log statements should go through @logNow@.
printHttpLogs
  :: Handle
  -> Maybe (MVar ())
  -> LogOptions e w
  -> (LogOptions e w -> LogEntry e w -> Maybe Text)
  -> W e w
  -> IO ()
printHttpLogs :: Handle
-> Maybe (MVar ())
-> LogOptions e w
-> (LogOptions e w -> LogEntry e w -> Maybe Text)
-> W e w
-> IO ()
printHttpLogs Handle
handle Maybe (MVar ())
lock LogOptions e w
opts LogOptions e w -> LogEntry e w -> Maybe Text
printer (W [LogEntry e w]
ws) = do
  let
    printEntry :: LogEntry e w -> IO ()
printEntry LogEntry e w
w = 
      case LogOptions e w -> LogEntry e w -> Maybe Text
printer LogOptions e w
opts LogEntry e w
w of
        Maybe Text
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Text
str -> do
          case Maybe (MVar ())
lock of
            Just MVar ()
lock -> MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (\() -> Handle -> Text -> IO ()
T.hPutStrLn Handle
handle Text
str)
            Maybe (MVar ())
Nothing -> Handle -> Text -> IO ()
T.hPutStrLn Handle
handle Text
str
          Handle -> IO ()
hFlush Handle
handle

  if LogOptions e w -> Bool
forall e w. LogOptions e w -> Bool
_logSilent LogOptions e w
opts
    then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else (LogEntry e w -> IO ()) -> [LogEntry e w] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LogEntry e w -> IO ()
printEntry [LogEntry e w]
ws



-- | Convert errors to log entries
errorMessage :: E e -> Log e w
errorMessage :: E e -> Log e w
errorMessage E e
e = case E e
e of
  E_Http HttpException
err -> HttpException -> Log e w
forall e w. HttpException -> Log e w
L_HttpError HttpException
err
  E_IO IOException
err -> IOException -> Log e w
forall e w. IOException -> Log e w
L_IOError IOException
err
  E_Json JsonError
err -> JsonError -> Log e w
forall e w. JsonError -> Log e w
L_JsonError JsonError
err
  E e
e -> e -> Log e w
forall e w. e -> Log e w
L_Error e
e

type LogEntryTitle = Text
type LogEntryBody = Text

logEntryBody
  :: LogOptions e w
  -> Log e w
  -> LogEntryBody
logEntryBody :: LogOptions e w -> Log e w -> Text
logEntryBody LogOptions{Bool
LogSeverity
Bool -> e -> Text
Bool -> w -> Text
_printUserLog :: Bool -> w -> Text
_printUserError :: Bool -> e -> Text
_logHeaders :: Bool
_logMinSeverity :: LogSeverity
_logSilent :: Bool
_logJson :: Bool
_logColor :: Bool
_printUserLog :: forall e w. LogOptions e w -> Bool -> w -> Text
_printUserError :: forall e w. LogOptions e w -> Bool -> e -> Text
_logHeaders :: forall e w. LogOptions e w -> Bool
_logMinSeverity :: forall e w. LogOptions e w -> LogSeverity
_logSilent :: forall e w. LogOptions e w -> Bool
_logJson :: forall e w. LogOptions e w -> Bool
_logColor :: forall e w. LogOptions e w -> Bool
..} Log e w
entry = case Log e w
entry of
  L_Comment Text
msg -> Text
msg

  L_Request HttpVerb
verb Text
url Options
opt Maybe ByteString
payload ->
    let
      head :: Text
      head :: Text
head = case (Bool
_logJson, Bool
_logHeaders) of
        (Bool
True,  Bool
True)  -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Value
jsonResponseHeaders (ResponseHeaders -> Value) -> ResponseHeaders -> Value
forall a b. (a -> b) -> a -> b
$ Options
opt Options
-> Getting ResponseHeaders Options ResponseHeaders
-> ResponseHeaders
forall s a. s -> Getting a s a -> a
^. Getting ResponseHeaders Options ResponseHeaders
Lens' Options ResponseHeaders
Wreq.headers
        (Bool
False, Bool
True)  -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> String
forall a. Show a => a -> String
show (ResponseHeaders -> String) -> ResponseHeaders -> String
forall a b. (a -> b) -> a -> b
$ Options
opt Options
-> Getting ResponseHeaders Options ResponseHeaders
-> ResponseHeaders
forall s a. s -> Getting a s a -> a
^. Getting ResponseHeaders Options ResponseHeaders
Lens' Options ResponseHeaders
Wreq.headers
        (Bool
_,     Bool
False) -> Text
""

      body :: Text
      body :: Text
body = case (Bool
_logJson, Maybe ByteString
payload) of
        (Bool
True,  Just ByteString
p)  -> case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
p of
          Maybe Value
Nothing -> Text
"JSON parse error:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
toStrict ByteString
p)
          Just Value
v -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Value
v :: Value)
        (Bool
False, Just ByteString
p)  -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
p
        (Bool
_,     Maybe ByteString
Nothing) -> Text
""

    in
      Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"")
        [ [Text] -> Text
T.unwords [Text
"Request", String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpVerb -> String
forall a. Show a => a -> String
show HttpVerb
verb, Text
url]
        , Text
head
        , Text
body
        ]

  Log e w
L_SilentRequest -> Text
""

  L_Response HttpResponse
response ->
    let
      head :: Text
      head :: Text
head = case (Bool
_logJson, Bool
_logHeaders) of
        (Bool
True,  Bool
True)  -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Value
jsonResponseHeaders (ResponseHeaders -> Value) -> ResponseHeaders -> Value
forall a b. (a -> b) -> a -> b
$ HttpResponse -> ResponseHeaders
_responseHeaders HttpResponse
response
        (Bool
False, Bool
True)  -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> String
forall a. Show a => a -> String
show (ResponseHeaders -> String) -> ResponseHeaders -> String
forall a b. (a -> b) -> a -> b
$ HttpResponse -> ResponseHeaders
_responseHeaders HttpResponse
response
        (Bool
_,     Bool
False) -> Text
""

      body :: Text
      body :: Text
body = case Bool
_logJson of
        Bool
True  -> ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$
          Maybe Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Maybe Value -> ByteString) -> Maybe Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Getting (First Value) ByteString Value -> ByteString -> Maybe Value
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Value) ByteString Value
forall t. AsValue t => Prism' t Value
_Value (ByteString -> Maybe Value) -> ByteString -> Maybe Value
forall a b. (a -> b) -> a -> b
$ HttpResponse -> ByteString
_responseBody HttpResponse
response
        Bool
False -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpResponse -> String
forall a. Show a => a -> String
show HttpResponse
response

    in
      Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") [Text
"Response", Text
head, Text
body]

  Log e w
L_SilentResponse -> Text
""

  L_Pause Int
k -> Text
"Wait for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
k) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"μs"

  L_HttpError HttpException
e -> if Bool
_logJson
    then
      let
        unpackHttpError :: HttpException -> Maybe (Text, Text)
        unpackHttpError :: HttpException -> Maybe (Text, Text)
unpackHttpError HttpException
err = case HttpException
err of
          HttpExceptionRequest Request
_ (StatusCodeException Response ()
s ByteString
r) -> do
            Value
json <- ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe Value) -> ByteString -> Maybe Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
r
            let status :: Status
status = Response ()
s Response () -> Getting Status (Response ()) Status -> Status
forall s a. s -> Getting a s a -> a
^. Getting Status (Response ()) Status
forall body. Lens' (Response body) Status
Wreq.responseStatus 
            (Text, Text) -> Maybe (Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Status -> String
forall a. Show a => a -> String
show Status
status, ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Value
json :: Value))
          HttpException
_ -> Maybe (Text, Text)
forall a. Maybe a
Nothing
      in
        case HttpException -> Maybe (Text, Text)
unpackHttpError HttpException
e of
          Maybe (Text, Text)
Nothing -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
e
          Just (Text
code, Text
json) -> Text -> [Text] -> Text
T.intercalate Text
"\n" [ [Text] -> Text
T.unwords [ Text
"HTTP Error Response", Text
code], Text
json ]

    else String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
e

  L_IOError IOException
e -> [Text] -> Text
T.unwords
    [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Maybe String -> String
forall a. Show a => a -> String
show (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ IOException -> Maybe String
ioeGetFileName IOException
e
    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
ioeGetLocation IOException
e
    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ IOException -> String
ioeGetErrorString IOException
e
    ]

  L_JsonError JsonError
e -> String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ JsonError -> String
forall a. Show a => a -> String
show JsonError
e

  L_Error e
e -> [Text] -> Text
T.unwords [ Bool -> e -> Text
_printUserError Bool
_logJson e
e ]

  L_Log w
w -> [Text] -> Text
T.unwords [ Bool -> w -> Text
_printUserLog Bool
_logJson w
w ]



-- | Extract the user-defined log entries.
logEntries :: W e w -> [w]
logEntries :: W e w -> [w]
logEntries (W [LogEntry e w]
xs) = [LogEntry e w] -> [w]
forall e a. [LogEntry e a] -> [a]
entries [LogEntry e w]
xs
  where
    entries :: [LogEntry e a] -> [a]
entries [] = []
    entries (LogEntry e a
w:[LogEntry e a]
ws) = case LogEntry e a -> Log e a
forall e w. LogEntry e w -> Log e w
_logEntry LogEntry e a
w of
      L_Log a
u -> a
u a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [LogEntry e a] -> [a]
entries [LogEntry e a]
ws
      Log e a
_ -> [LogEntry e a] -> [a]
entries [LogEntry e a]
ws



-- | State type
data S s = S
  { S s -> Options
_httpOptions :: Wreq.Options
  , S s -> Maybe Session
_httpSession :: Maybe S.Session
  , S s -> s
_userState :: s
  } deriving Int -> S s -> ShowS
[S s] -> ShowS
S s -> String
(Int -> S s -> ShowS)
-> (S s -> String) -> ([S s] -> ShowS) -> Show (S s)
forall s. Show s => Int -> S s -> ShowS
forall s. Show s => [S s] -> ShowS
forall s. Show s => S s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [S s] -> ShowS
$cshowList :: forall s. Show s => [S s] -> ShowS
show :: S s -> String
$cshow :: forall s. Show s => S s -> String
showsPrec :: Int -> S s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> S s -> ShowS
Show

-- | State constructor
basicState :: s -> S s
basicState :: s -> S s
basicState s
s = S :: forall s. Options -> Maybe Session -> s -> S s
S
  { _httpOptions :: Options
_httpOptions = Options
Wreq.defaults
  , _httpSession :: Maybe Session
_httpSession = Maybe Session
forall a. Maybe a
Nothing
  , _userState :: s
_userState = s
s
  }



-- | Atomic effects
data P p a where
  HPutStrLn
    :: Handle -> Text
    -> P p (Either IOException ())
  HPutStrLnBlocking
    :: MVar () -> Handle -> Text
    -> P p (Either IOException ())

  GetSystemTime :: P p UTCTime
  ThreadDelay :: Int -> P p ()

  HttpGet
    :: Wreq.Options -> Maybe S.Session -> Url
    -> P p (Either HttpException HttpResponse)
  HttpPost
    :: Wreq.Options -> Maybe S.Session -> Url
    -> ByteString -> P p (Either HttpException HttpResponse)
  HttpDelete
    :: Wreq.Options -> Maybe S.Session -> Url
    -> P p (Either HttpException HttpResponse)

  P :: p a -> P p a

-- | Basic evaluator for interpreting atomic 'Http' effects in 'IO'.
evalIO
  :: (p a -> IO a) -- ^ Evaluator for user effects
  -> P p a
  -> IO a
evalIO :: (p a -> IO a) -> P p a -> IO a
evalIO p a -> IO a
eval P p a
x = case P p a
x of
  HPutStrLn Handle
handle Text
string -> IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ do
    Handle -> Text -> IO ()
T.hPutStrLn Handle
handle Text
string
    Handle -> IO ()
hFlush Handle
handle

  HPutStrLnBlocking MVar ()
lock Handle
handle Text
str -> IO () -> IO (Either IOException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ do
    MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (\() -> Handle -> Text -> IO ()
T.hPutStrLn Handle
handle Text
str)
    Handle -> IO ()
hFlush Handle
handle

  P p a
GetSystemTime -> (SystemTime -> UTCTime) -> IO SystemTime -> IO UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SystemTime -> UTCTime
systemToUTCTime IO SystemTime
getSystemTime

  ThreadDelay Int
k -> Int -> IO ()
threadDelay Int
k

  HttpGet Options
opts Maybe Session
s Text
url ->
    let url' :: String
url' = Text -> String
T.unpack Text
url
    in case Maybe Session
s of
      Maybe Session
Nothing -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> String -> IO (Response ByteString)
Wreq.getWith Options
opts String
url'
      Just Session
sn -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Session -> String -> IO (Response ByteString)
S.getWith Options
opts Session
sn String
url'

  HttpPost Options
opts Maybe Session
s Text
url ByteString
msg ->
    let url' :: String
url' = Text -> String
T.unpack Text
url
    in case Maybe Session
s of
      Maybe Session
Nothing -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> String -> ByteString -> IO (Response ByteString)
forall a.
Postable a =>
Options -> String -> a -> IO (Response ByteString)
Wreq.postWith Options
opts String
url' ByteString
msg
      Just Session
sn -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options
-> Session -> String -> ByteString -> IO (Response ByteString)
forall a.
Postable a =>
Options -> Session -> String -> a -> IO (Response ByteString)
S.postWith Options
opts Session
sn String
url' ByteString
msg

  HttpDelete Options
opts Maybe Session
s Text
url ->
    let url' :: String
url' = Text -> String
T.unpack Text
url
    in case Maybe Session
s of
      Maybe Session
Nothing -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> String -> IO (Response ByteString)
Wreq.deleteWith Options
opts String
url'
      Just Session
sn -> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO HttpResponse -> IO (Either HttpException HttpResponse))
-> IO HttpResponse -> IO (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> HttpResponse
readHttpResponse (Response ByteString -> HttpResponse)
-> IO (Response ByteString) -> IO HttpResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Session -> String -> IO (Response ByteString)
S.deleteWith Options
opts Session
sn String
url'

  P p a
act -> p a -> IO a
eval p a
act

-- | Basic evaluator for interpreting atomic 'Http' effects in 'MockIO'.
evalMockIO
  :: (p a -> MockIO s a)
  -> P p a
  -> MockIO s a
evalMockIO :: (p a -> MockIO s a) -> P p a -> MockIO s a
evalMockIO p a -> MockIO s a
eval P p a
x = case P p a
x of
  HPutStrLn Handle
handle Text
str -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    (() -> Either IOException ())
-> MockIO s () -> MockIO s (Either IOException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either IOException ()
forall a b. b -> Either a b
Right (MockIO s () -> MockIO s (Either IOException ()))
-> MockIO s () -> MockIO s (Either IOException ())
forall a b. (a -> b) -> a -> b
$ (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w
      { _files :: FileSystem (Either String Handle)
_files = Either String Handle
-> [Text]
-> FileSystem (Either String Handle)
-> FileSystem (Either String Handle)
forall a. Eq a => a -> [Text] -> FileSystem a -> FileSystem a
appendLines (Handle -> Either String Handle
forall a b. b -> Either a b
Right Handle
handle) (Text -> [Text]
T.lines Text
str) (FileSystem (Either String Handle)
 -> FileSystem (Either String Handle))
-> FileSystem (Either String Handle)
-> FileSystem (Either String Handle)
forall a b. (a -> b) -> a -> b
$ MockWorld s -> FileSystem (Either String Handle)
forall s. MockWorld s -> FileSystem (Either String Handle)
_files MockWorld s
w }

  HPutStrLnBlocking MVar ()
_ Handle
handle Text
str -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    (() -> Either IOException ())
-> MockIO s () -> MockIO s (Either IOException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap () -> Either IOException ()
forall a b. b -> Either a b
Right (MockIO s () -> MockIO s (Either IOException ()))
-> MockIO s () -> MockIO s (Either IOException ())
forall a b. (a -> b) -> a -> b
$ (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w
      { _files :: FileSystem (Either String Handle)
_files = Either String Handle
-> [Text]
-> FileSystem (Either String Handle)
-> FileSystem (Either String Handle)
forall a. Eq a => a -> [Text] -> FileSystem a -> FileSystem a
appendLines (Handle -> Either String Handle
forall a b. b -> Either a b
Right Handle
handle) (Text -> [Text]
T.lines Text
str) (FileSystem (Either String Handle)
 -> FileSystem (Either String Handle))
-> FileSystem (Either String Handle)
-> FileSystem (Either String Handle)
forall a b. (a -> b) -> a -> b
$ MockWorld s -> FileSystem (Either String Handle)
forall s. MockWorld s -> FileSystem (Either String Handle)
_files MockWorld s
w }

  P p a
GetSystemTime -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    MockWorld{UTCTime
FileSystem (Either String Handle)
MockServer s
Text -> MockNetwork s HttpResponse
Text -> ByteString -> MockNetwork s HttpResponse
_serverState :: forall s. MockWorld s -> MockServer s
_httpDelete :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_httpPost :: forall s.
MockWorld s -> Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_time :: forall s. MockWorld s -> UTCTime
_serverState :: MockServer s
_httpDelete :: Text -> MockNetwork s HttpResponse
_httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: Text -> MockNetwork s HttpResponse
_time :: UTCTime
_files :: FileSystem (Either String Handle)
_files :: forall s. MockWorld s -> FileSystem (Either String Handle)
..} <- MockIO s (MockWorld s)
forall s. MockIO s (MockWorld s)
getMockWorld
    UTCTime -> MockIO s UTCTime
forall (m :: * -> *) a. Monad m => a -> m a
return UTCTime
_time

  ThreadDelay Int
k -> Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
k

  HttpGet Options
_ Maybe Session
_ Text
url -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    MockWorld{UTCTime
FileSystem (Either String Handle)
MockServer s
Text -> MockNetwork s HttpResponse
Text -> ByteString -> MockNetwork s HttpResponse
_serverState :: MockServer s
_httpDelete :: Text -> MockNetwork s HttpResponse
_httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: Text -> MockNetwork s HttpResponse
_time :: UTCTime
_files :: FileSystem (Either String Handle)
_serverState :: forall s. MockWorld s -> MockServer s
_httpDelete :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_httpPost :: forall s.
MockWorld s -> Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_time :: forall s. MockWorld s -> UTCTime
_files :: forall s. MockWorld s -> FileSystem (Either String Handle)
..} <- MockIO s (MockWorld s)
forall s. MockIO s (MockWorld s)
getMockWorld
    let (Either HttpException HttpResponse
r,MockServer s
t) = MockNetwork s HttpResponse
-> MockServer s
-> (Either HttpException HttpResponse, MockServer s)
forall s a.
MockNetwork s a
-> MockServer s -> (Either HttpException a, MockServer s)
unMockNetwork (Text -> MockNetwork s HttpResponse
_httpGet Text
url) MockServer s
_serverState
    (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w { _serverState :: MockServer s
_serverState = MockServer s
t }
    Either HttpException HttpResponse
-> MockIO s (Either HttpException HttpResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException HttpResponse
r

  HttpPost Options
_ Maybe Session
_ Text
url ByteString
payload -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    MockWorld{UTCTime
FileSystem (Either String Handle)
MockServer s
Text -> MockNetwork s HttpResponse
Text -> ByteString -> MockNetwork s HttpResponse
_serverState :: MockServer s
_httpDelete :: Text -> MockNetwork s HttpResponse
_httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: Text -> MockNetwork s HttpResponse
_time :: UTCTime
_files :: FileSystem (Either String Handle)
_serverState :: forall s. MockWorld s -> MockServer s
_httpDelete :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_httpPost :: forall s.
MockWorld s -> Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_time :: forall s. MockWorld s -> UTCTime
_files :: forall s. MockWorld s -> FileSystem (Either String Handle)
..} <- MockIO s (MockWorld s)
forall s. MockIO s (MockWorld s)
getMockWorld
    let (Either HttpException HttpResponse
r,MockServer s
t) = MockNetwork s HttpResponse
-> MockServer s
-> (Either HttpException HttpResponse, MockServer s)
forall s a.
MockNetwork s a
-> MockServer s -> (Either HttpException a, MockServer s)
unMockNetwork (Text -> ByteString -> MockNetwork s HttpResponse
_httpPost Text
url ByteString
payload) MockServer s
_serverState
    (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w { _serverState :: MockServer s
_serverState = MockServer s
t }
    Either HttpException HttpResponse
-> MockIO s (Either HttpException HttpResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException HttpResponse
r

  HttpDelete Options
_ Maybe Session
_ Text
url -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    MockWorld{UTCTime
FileSystem (Either String Handle)
MockServer s
Text -> MockNetwork s HttpResponse
Text -> ByteString -> MockNetwork s HttpResponse
_serverState :: MockServer s
_httpDelete :: Text -> MockNetwork s HttpResponse
_httpPost :: Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: Text -> MockNetwork s HttpResponse
_time :: UTCTime
_files :: FileSystem (Either String Handle)
_serverState :: forall s. MockWorld s -> MockServer s
_httpDelete :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_httpPost :: forall s.
MockWorld s -> Text -> ByteString -> MockNetwork s HttpResponse
_httpGet :: forall s. MockWorld s -> Text -> MockNetwork s HttpResponse
_time :: forall s. MockWorld s -> UTCTime
_files :: forall s. MockWorld s -> FileSystem (Either String Handle)
..} <- MockIO s (MockWorld s)
forall s. MockIO s (MockWorld s)
getMockWorld
    let (Either HttpException HttpResponse
r,MockServer s
t) = MockNetwork s HttpResponse
-> MockServer s
-> (Either HttpException HttpResponse, MockServer s)
forall s a.
MockNetwork s a
-> MockServer s -> (Either HttpException a, MockServer s)
unMockNetwork (Text -> MockNetwork s HttpResponse
_httpDelete Text
url) MockServer s
_serverState
    (MockWorld s -> MockWorld s) -> MockIO s ()
forall s. (MockWorld s -> MockWorld s) -> MockIO s ()
modifyMockWorld ((MockWorld s -> MockWorld s) -> MockIO s ())
-> (MockWorld s -> MockWorld s) -> MockIO s ()
forall a b. (a -> b) -> a -> b
$ \MockWorld s
w -> MockWorld s
w { _serverState :: MockServer s
_serverState = MockServer s
t }
    Either HttpException HttpResponse
-> MockIO s (Either HttpException HttpResponse)
forall (m :: * -> *) a. Monad m => a -> m a
return Either HttpException HttpResponse
r

  P p a
p -> do
    Int -> MockIO s ()
forall s. Int -> MockIO s ()
incrementTimer Int
1
    p a -> MockIO s a
eval p a
p



-- | All log statements should go through @logNow@.
logNow
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => LogSeverity
  -> Log e w
  -> HttpTT e r w s p t eff ()
logNow :: LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
severity Log e w
msg = do
  UTCTime
time <- P p UTCTime -> HttpTT e r w s p t eff UTCTime
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt P p UTCTime
forall (p :: * -> *). P p UTCTime
GetSystemTime
  LogOptions e w -> LogEntry e w -> Maybe Text
printer <- (R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text)
-> HttpTT
     e r w s p t eff (LogOptions e w -> LogEntry e w -> Maybe Text)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r a s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
(R e w r -> a) -> HttpTT e r w s p t eff a
reader R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logEntryPrinter
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  case LogOptions e w -> LogEntry e w -> Maybe Text
printer LogOptions e w
_logOptions (UTCTime -> Text -> LogSeverity -> Log e w -> LogEntry e w
forall e w.
UTCTime -> Text -> LogSeverity -> Log e w -> LogEntry e w
LogEntry UTCTime
time Text
_uid LogSeverity
severity Log e w
msg) of
    Maybe Text
Nothing -> () -> HttpTT e r w s p t eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Text
str -> case Maybe (MVar ())
_logLock of
      Just MVar ()
lock -> MVar () -> Handle -> Text -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
MVar () -> Handle -> Text -> HttpTT e r w s p t eff ()
hPutStrLnBlocking MVar ()
lock Handle
_logHandle Text
str
      Maybe (MVar ())
Nothing -> Handle -> Text -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
Handle -> Text -> HttpTT e r w s p t eff ()
Control.Monad.Script.Http.hPutStrLn Handle
_logHandle Text
str
  W e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
W e w -> HttpTT e r w s p t eff ()
tell (W e w -> HttpTT e r w s p t eff ())
-> W e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ [LogEntry e w] -> W e w
forall e w. [LogEntry e w] -> W e w
W [UTCTime -> Text -> LogSeverity -> Log e w -> LogEntry e w
forall e w.
UTCTime -> Text -> LogSeverity -> Log e w -> LogEntry e w
LogEntry UTCTime
time Text
_uid LogSeverity
severity Log e w
msg]

-- | Write a comment to the log
comment
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Text
  -> HttpTT e r w s p t eff ()
comment :: Text -> HttpTT e r w s p t eff ()
comment Text
msg = LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogInfo (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ Text -> Log e w
forall e w. Text -> Log e w
L_Comment Text
msg

-- | Pause the thread
wait
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Int -- ^ milliseconds
  -> HttpTT e r w s p t eff ()
wait :: Int -> HttpTT e r w s p t eff ()
wait Int
k = do
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogInfo (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ Int -> Log e w
forall e w. Int -> Log e w
L_Pause Int
k
  P p () -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p () -> HttpTT e r w s p t eff ())
-> P p () -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ Int -> P p ()
forall (p :: * -> *). Int -> P p ()
ThreadDelay Int
k

-- | Write an entry to the log
logEntry
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry :: LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
severity = LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
severity (Log e w -> HttpTT e r w s p t eff ())
-> (w -> Log e w) -> w -> HttpTT e r w s p t eff ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> Log e w
forall e w. w -> Log e w
L_Log

-- | For debug level messages
logDebug
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logDebug :: w -> HttpTT e r w s p t eff ()
logDebug = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogDebug

-- | For informational messages
logInfo
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logInfo :: w -> HttpTT e r w s p t eff ()
logInfo = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogInfo

-- | For normal but significant conditions
logNotice
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logNotice :: w -> HttpTT e r w s p t eff ()
logNotice = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogNotice

-- | For warning conditions
logWarning
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logWarning :: w -> HttpTT e r w s p t eff ()
logWarning = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogWarning

-- | For error conditions
logError
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logError :: w -> HttpTT e r w s p t eff ()
logError = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogError

-- | For critical conditions
logCritical
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logCritical :: w -> HttpTT e r w s p t eff ()
logCritical = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogCritical

-- | Action must be taken immediately
logAlert
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logAlert :: w -> HttpTT e r w s p t eff ()
logAlert = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogAlert

-- | System is unusable
logEmergency
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => w -> HttpTT e r w s p t eff ()
logEmergency :: w -> HttpTT e r w s p t eff ()
logEmergency = LogSeverity -> w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) w e r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> w -> HttpTT e r w s p t eff ()
logEntry LogSeverity
LogEmergency

-- | Set the severity level of all log actions in a session.
setLogSeverity
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => LogSeverity
  -> HttpTT e r w s p t eff a
  -> HttpTT e r w s p t eff a
setLogSeverity :: LogSeverity -> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff a
setLogSeverity LogSeverity
severity = (W e w -> W e w)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
(W e w -> W e w)
-> HttpTT e r w s p t eff a -> HttpTT e r w s p t eff a
censor ([LogEntry e w] -> W e w
forall e w. [LogEntry e w] -> W e w
W ([LogEntry e w] -> W e w)
-> (W e w -> [LogEntry e w]) -> W e w -> W e w
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEntry e w -> LogEntry e w) -> [LogEntry e w] -> [LogEntry e w]
forall a b. (a -> b) -> [a] -> [b]
map LogEntry e w -> LogEntry e w
forall e w. LogEntry e w -> LogEntry e w
f ([LogEntry e w] -> [LogEntry e w])
-> (W e w -> [LogEntry e w]) -> W e w -> [LogEntry e w]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. W e w -> [LogEntry e w]
forall e w. W e w -> [LogEntry e w]
unW)
  where
    f :: LogEntry e w -> LogEntry e w
    f :: LogEntry e w -> LogEntry e w
f LogEntry e w
e = LogEntry e w
e { _logEntrySeverity :: LogSeverity
_logEntrySeverity = LogSeverity
severity }



-- | Write a line to a handle
hPutStrLn
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Handle
  -> Text
  -> HttpTT e r w s p t eff ()
hPutStrLn :: Handle -> Text -> HttpTT e r w s p t eff ()
hPutStrLn Handle
h Text
str = do
  Either IOException ()
result <- P p (Either IOException ())
-> HttpTT e r w s p t eff (Either IOException ())
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either IOException ())
 -> HttpTT e r w s p t eff (Either IOException ()))
-> P p (Either IOException ())
-> HttpTT e r w s p t eff (Either IOException ())
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> P p (Either IOException ())
forall (p :: * -> *). Handle -> Text -> P p (Either IOException ())
HPutStrLn Handle
h Text
str
  case Either IOException ()
result of
    Right () -> () -> HttpTT e r w s p t eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left IOException
e -> IOException -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
IOException -> HttpTT e r w s p t eff a
throwIOException IOException
e

-- | Write a line to a handle, using the given `MVar` as a lock
hPutStrLnBlocking
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => MVar ()
  -> Handle
  -> Text
  -> HttpTT e r w s p t eff ()
hPutStrLnBlocking :: MVar () -> Handle -> Text -> HttpTT e r w s p t eff ()
hPutStrLnBlocking MVar ()
lock Handle
h Text
str = do
  Either IOException ()
result <- P p (Either IOException ())
-> HttpTT e r w s p t eff (Either IOException ())
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either IOException ())
 -> HttpTT e r w s p t eff (Either IOException ()))
-> P p (Either IOException ())
-> HttpTT e r w s p t eff (Either IOException ())
forall a b. (a -> b) -> a -> b
$ MVar () -> Handle -> Text -> P p (Either IOException ())
forall (p :: * -> *).
MVar () -> Handle -> Text -> P p (Either IOException ())
HPutStrLnBlocking MVar ()
lock Handle
h Text
str
  case Either IOException ()
result of
    Right () -> () -> HttpTT e r w s p t eff ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Left IOException
e -> IOException -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
IOException -> HttpTT e r w s p t eff a
throwIOException IOException
e



-- | Run a @GET@ request
httpGet
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> HttpTT e r w s p t eff HttpResponse
httpGet :: Text -> HttpTT e r w s p t eff HttpResponse
httpGet Text
url = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
forall e w.
HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
L_Request HttpVerb
GET Text
url Options
_httpOptions Maybe ByteString
forall a. Maybe a
Nothing
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
HttpGet Options
_httpOptions Maybe Session
_httpSession Text
url
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpResponse -> Log e w
forall e w. HttpResponse -> Log e w
L_Response HttpResponse
response
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err

-- | Run a @GET@ request, but do not write the request or response to the logs.
httpSilentGet
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> HttpTT e r w s p t eff HttpResponse
httpSilentGet :: Text -> HttpTT e r w s p t eff HttpResponse
httpSilentGet Text
url = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentRequest
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
HttpGet Options
_httpOptions Maybe Session
_httpSession Text
url
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentResponse
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err

-- | Run a @POST@ request
httpPost
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> ByteString -- ^ Payload
  -> HttpTT e r w s p t eff HttpResponse
httpPost :: Text -> ByteString -> HttpTT e r w s p t eff HttpResponse
httpPost Text
url ByteString
payload = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
forall e w.
HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
L_Request HttpVerb
POST Text
url Options
_httpOptions (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
payload)
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session
-> Text
-> ByteString
-> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session
-> Text
-> ByteString
-> P p (Either HttpException HttpResponse)
HttpPost Options
_httpOptions Maybe Session
_httpSession Text
url ByteString
payload
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpResponse -> Log e w
forall e w. HttpResponse -> Log e w
L_Response HttpResponse
response
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err

-- | Run a @POST@ request, but do not write the request or response to the logs.
httpSilentPost
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> ByteString -- ^ Payload
  -> HttpTT e r w s p t eff HttpResponse
httpSilentPost :: Text -> ByteString -> HttpTT e r w s p t eff HttpResponse
httpSilentPost Text
url ByteString
payload = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentRequest
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session
-> Text
-> ByteString
-> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session
-> Text
-> ByteString
-> P p (Either HttpException HttpResponse)
HttpPost Options
_httpOptions Maybe Session
_httpSession Text
url ByteString
payload
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentResponse
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err

-- | Run a @DELETE@ request
httpDelete
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> HttpTT e r w s p t eff HttpResponse
httpDelete :: Text -> HttpTT e r w s p t eff HttpResponse
httpDelete Text
url = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug (Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
forall e w.
HttpVerb -> Text -> Options -> Maybe ByteString -> Log e w
L_Request HttpVerb
DELETE Text
url Options
_httpOptions Maybe ByteString
forall a. Maybe a
Nothing
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
HttpDelete Options
_httpOptions Maybe Session
_httpSession Text
url
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug(Log e w -> HttpTT e r w s p t eff ())
-> Log e w -> HttpTT e r w s p t eff ()
forall a b. (a -> b) -> a -> b
$ HttpResponse -> Log e w
forall e w. HttpResponse -> Log e w
L_Response HttpResponse
response
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err

-- | Run a @DELETE@ request, but do not write the request or response to the logs.
httpSilentDelete
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Url
  -> HttpTT e r w s p t eff HttpResponse
httpSilentDelete :: Text -> HttpTT e r w s p t eff HttpResponse
httpSilentDelete Text
url = do
  R{r
Maybe (MVar ())
Text
Handle
LogOptions e w
HttpException -> Maybe e
LogOptions e w -> LogEntry e w -> Maybe Text
_env :: r
_httpErrorInject :: HttpException -> Maybe e
_uid :: Text
_logLock :: Maybe (MVar ())
_logHandle :: Handle
_logEntryPrinter :: LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: LogOptions e w
_env :: forall e w r. R e w r -> r
_httpErrorInject :: forall e w r. R e w r -> HttpException -> Maybe e
_uid :: forall e w r. R e w r -> Text
_logLock :: forall e w r. R e w r -> Maybe (MVar ())
_logHandle :: forall e w r. R e w r -> Handle
_logEntryPrinter :: forall e w r.
R e w r -> LogOptions e w -> LogEntry e w -> Maybe Text
_logOptions :: forall e w r. R e w r -> LogOptions e w
..} <- HttpTT e r w s p t eff (R e w r)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (R e w r)
ask
  S{s
Maybe Session
Options
_userState :: s
_httpSession :: Maybe Session
_httpOptions :: Options
_userState :: forall s. S s -> s
_httpSession :: forall s. S s -> Maybe Session
_httpOptions :: forall s. S s -> Options
..} <- HttpTT e r w s p t eff (S s)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpTT e r w s p t eff (S s)
get
  LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentRequest
  Either HttpException HttpResponse
result <- P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) (p :: * -> *) a e
       r w s.
(Monad eff, Monad (t eff), MonadTrans t) =>
P p a -> HttpTT e r w s p t eff a
prompt (P p (Either HttpException HttpResponse)
 -> HttpTT e r w s p t eff (Either HttpException HttpResponse))
-> P p (Either HttpException HttpResponse)
-> HttpTT e r w s p t eff (Either HttpException HttpResponse)
forall a b. (a -> b) -> a -> b
$ Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
forall (p :: * -> *).
Options
-> Maybe Session -> Text -> P p (Either HttpException HttpResponse)
HttpDelete Options
_httpOptions Maybe Session
_httpSession Text
url
  case Either HttpException HttpResponse
result of
    Right HttpResponse
response -> do
      LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e w r s
       (p :: * -> *).
(Monad eff, Monad (t eff), MonadTrans t) =>
LogSeverity -> Log e w -> HttpTT e r w s p t eff ()
logNow LogSeverity
LogDebug Log e w
forall e w. Log e w
L_SilentResponse
      HttpResponse -> HttpTT e r w s p t eff HttpResponse
forall (m :: * -> *) a. Monad m => a -> m a
return HttpResponse
response
    Left HttpException
err -> case HttpException -> Maybe e
_httpErrorInject HttpException
err of
      Just e
z -> e -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
e -> HttpTT e r w s p t eff a
throwError e
z
      Maybe e
Nothing -> HttpException -> HttpTT e r w s p t eff HttpResponse
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
HttpException -> HttpTT e r w s p t eff a
throwHttpException HttpException
err



-- | Parse a `ByteString` to a JSON `Value`.
parseJson
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => ByteString
  -> HttpTT e r w s p t eff Value
parseJson :: ByteString -> HttpTT e r w s p t eff Value
parseJson ByteString
bytes = case Getting (First Value) ByteString Value -> ByteString -> Maybe Value
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First Value) ByteString Value
forall t. AsValue t => Prism' t Value
_Value ByteString
bytes of
  Just Value
value -> Value -> HttpTT e r w s p t eff Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value
  Maybe Value
Nothing -> JsonError -> HttpTT e r w s p t eff Value
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
JsonError -> HttpTT e r w s p t eff a
throwJsonError (JsonError -> HttpTT e r w s p t eff Value)
-> JsonError -> HttpTT e r w s p t eff Value
forall a b. (a -> b) -> a -> b
$ ByteString -> JsonError
JsonParseError ByteString
bytes

-- | Object member lookup.
lookupKeyJson
  :: (Monad eff, Monad (t eff), MonadTrans t)
  => Text -- ^ Key name
  -> Value -- ^ JSON object
  -> HttpTT e r w s p t eff Value
lookupKeyJson :: Text -> Value -> HttpTT e r w s p t eff Value
lookupKeyJson Text
key Value
v = case Value
v of
  Object Object
obj ->
    let
#if MIN_VERSION_aeson(2,0,0)
      val :: Maybe Value
val = Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
lookup (Text -> Key
fromText Text
key) Object
obj
#else
      val = lookup key obj
#endif
    in case Maybe Value
val of
      Maybe Value
Nothing -> JsonError -> HttpTT e r w s p t eff Value
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
JsonError -> HttpTT e r w s p t eff a
throwJsonError (JsonError -> HttpTT e r w s p t eff Value)
-> JsonError -> HttpTT e r w s p t eff Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> JsonError
JsonKeyDoesNotExist Text
key (Object -> Value
Object Object
obj)
      Just Value
value -> Value -> HttpTT e r w s p t eff Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
value
  Value
_ -> JsonError -> HttpTT e r w s p t eff Value
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
JsonError -> HttpTT e r w s p t eff a
throwJsonError (JsonError -> HttpTT e r w s p t eff Value)
-> JsonError -> HttpTT e r w s p t eff Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> JsonError
JsonKeyLookupOffObject Text
key Value
v

-- | Decode a `A.Value` to some other type.
constructFromJson
  :: (Monad eff, Monad (t eff), MonadTrans t, FromJSON a)
  => Value
  -> HttpTT e r w s p t eff a
constructFromJson :: Value -> HttpTT e r w s p t eff a
constructFromJson Value
value = case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON Value
value of
  Success a
x -> a -> HttpTT e r w s p t eff a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
  Error String
msg -> JsonError -> HttpTT e r w s p t eff a
forall (eff :: * -> *) (t :: (* -> *) -> * -> *) e r w s
       (p :: * -> *) a.
(Monad eff, Monad (t eff), MonadTrans t) =>
JsonError -> HttpTT e r w s p t eff a
throwJsonError (JsonError -> HttpTT e r w s p t eff a)
-> JsonError -> HttpTT e r w s p t eff a
forall a b. (a -> b) -> a -> b
$ String -> JsonError
JsonConstructError String
msg