module Web.Growler.Types where
import Blaze.ByteString.Builder (Builder)
import Control.Applicative
import Control.Exception
import Control.Lens.TH
import Control.Monad.Base (MonadBase(..), liftBaseDefault)
import Control.Monad.Trans
import Control.Monad.Trans.RWS.Strict
import Control.Monad.Trans.State.Strict hiding (get, put)
import Control.Monad.Trans.Either
import Control.Monad.Trans.Control
import Data.Aeson hiding ((.=))
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as HM
import Data.Monoid
import Data.String (IsString (..))
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types.Header
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Network.Wai
import Pipes.Aeson (DecodingError (..))
data MatchResult = Fail | Partial [Param] | Complete [Param]
deriving (Show, Eq)
newtype RoutePattern = RoutePattern { runRoutePattern :: Request -> RoutePatternResult }
data RoutePatternResult = RoutePatternResult
{ routePatternResultName :: !Text
, routePatternResultRequest :: !Request
, routePatternResultMatchResult :: !MatchResult
}
instance Monoid MatchResult where
mappend l r = case l of
Fail -> Fail
Partial lps -> case r of
Fail -> Fail
Partial rps -> Partial (lps <> rps)
Complete rps -> Complete (lps <> rps)
Complete lps -> case r of
Complete rps -> Complete (lps <> rps)
_ -> Fail
mempty = Partial []
instance Monoid RoutePattern where
mappend (RoutePattern a) (RoutePattern b) = RoutePattern $ \r -> let (RoutePatternResult t1 r' p1) = a r in
let (RoutePatternResult t2 r'' p2) = b r' in
RoutePatternResult (t1 <> t2) r'' (p1 <> p2)
mempty = RoutePattern $ \r -> RoutePatternResult "" r $ Partial []
instance IsString RoutePattern where
fromString = capture . T.pack
path :: Request -> T.Text
path r = case front of
Just ('/', _) -> full
_ -> T.cons '/' full
where
full = T.intercalate "/" $ pathInfo r
front = T.uncons full
capture :: Text -> RoutePattern
capture pat = RoutePattern process
where
process req = RoutePatternResult pat (req { pathInfo = ss }) res
where
(res, ss) = go (T.split (== '/') pat) (T.split (== '/') $ path req) []
go [] [] prs = (Complete prs, [])
go [] r prs | T.null (mconcat r) = (Complete prs, [])
| otherwise = (Partial prs, r)
go p [] prs | T.null (mconcat p) = (Complete prs, [])
| otherwise = (Fail, [])
go (p:ps) (r:rs) prs | p == r = go ps rs prs
| T.null p = (Fail, [])
| T.head p == ':' = go ps rs $ (T.encodeUtf8 $ T.tail p, T.encodeUtf8 r) : prs
| otherwise = (Fail, [])
type Param = (C.ByteString, C.ByteString)
data BodySource = FileSource !FilePath !(Maybe FilePart)
| BuilderSource !Builder
| LBSSource !L.ByteString
| StreamSource !StreamingBody
| RawSource !(IO C.ByteString -> (C.ByteString -> IO ()) -> IO ()) !Response
data RequestState = RequestState
{ requestStateMatchedPattern :: Maybe T.Text
, requestStateParams :: [Param]
, requestStateRequest :: Request
}
data ResponseState = ResponseState
{ responseStateStatus :: !Status
, responseStateHeaders :: !(HM.HashMap (CI.CI C.ByteString) [C.ByteString])
, responseStateBodySource :: !BodySource
}
makeFields ''ResponseState
makeFields ''RequestState
type EarlyTermination = ResponseState
type HandlerAbort m = EitherT EarlyTermination m
newtype HandlerT m a = HandlerT
{ fromHandler :: RWST RequestState () ResponseState (HandlerAbort m) a
} deriving (Functor, Monad, Applicative)
instance MonadTrans HandlerT where
lift m = HandlerT $ lift $ lift m
deriving instance MonadIO m => MonadIO (HandlerT m)
instance MonadBase b m => MonadBase b (HandlerT m) where
liftBase = liftBaseDefault
newtype StHandlerT a = StHandlerT { unStHandlerT :: Either ResponseState (a, ResponseState) }
instance MonadTransControl HandlerT where
type StT HandlerT a = StHandlerT a
liftWith f = do
r <- HandlerT ask
s <- HandlerT get
lift $ f $ \h -> do
res <- runEitherT $ runRWST (fromHandler h) r s
return $ StHandlerT $ case res of
Left s -> Left s
Right (x, s, _) -> Right (x, s)
restoreT mSt = HandlerT $ do
(StHandlerT stof) <- lift $ lift $ mSt
case stof of
Left s -> do
put s
lift $ left s
Right (x, s) -> do
put s
return x
instance MonadBaseControl b m => MonadBaseControl b (HandlerT m) where
type StM (HandlerT m) a = ComposeSt HandlerT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
type Handler = HandlerT IO
newtype GrowlerT m a = GrowlerT { fromGrowlerT :: StateT [(StdMethod, RoutePattern, HandlerT m ())] m a }
instance Functor m => Functor (GrowlerT m) where
fmap f (GrowlerT m) = GrowlerT (fmap f m)
instance (Functor m, Monad m) => Applicative (GrowlerT m) where
pure = GrowlerT . pure
(GrowlerT f) <*> (GrowlerT r) = GrowlerT (f <*> r)
deriving instance Monad m => Monad (GrowlerT m)
instance MonadIO m => MonadIO (GrowlerT m) where
liftIO = GrowlerT . liftIO
type Growler = GrowlerT IO
data JsonInputError = RequestBodyExhausted
| JsonError DecodingError
deriving (Show, Eq)
data GrowlerConfig m = GrowlerConfig
{ growlerConfigNotFoundHandler :: HandlerT m ()
, growlerConfigErrorHandler :: SomeException -> HandlerT m ()
}