Symantic/HTTP/Command.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Symantic.HTTP.Command where
   7
   8 import Data.Default.Class (Default(..))
   9 import Data.Function (($), (.), id)
  10 import Data.Functor ((<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Proxy (Proxy(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import GHC.Exts (IsList(..))
  15 import qualified Data.List as List
  16 import qualified Data.Sequence as Seq
  17 import qualified Data.Text.Encoding as Text
  18 import qualified Network.HTTP.Types as HTTP
  19 import qualified Web.HttpApiData as Web
  20
  21 import Symantic.HTTP.Media
  22 import Symantic.HTTP.API
  23 import Symantic.HTTP.Client
  24 import Symantic.HTTP.Mime
  25
  26 -- * Type 'Command'
  27 -- | 'Command a k' is a recipe to produce a 'ClientRequest'
  28 -- from arguments 'a' (one per number of alternative routes).
  29 --
  30 -- 'Command' is analogous to a printf using a format customized for HTTP routing.
  31 newtype Command a k = Command { unCommand :: (CommandModifier -> k) -> a} -- Right Kan extension
  32  -- deriving (Functor {-, Applicative, Alternative, Monad, MonadPlus, P.MonadParsec RouteError RouteTokens-})
  33
  34 -- | Useful to constrain 'repr' to be 'Command'.
  35 command :: Command a k -> Command a k
  36 command = id
  37
  38 -- | @'runCommand' api@ returns the 'ClientRequest's
  39 -- builders from the given 'api'.
  40 runCommand :: Command api ClientRequest -> api
  41 runCommand (Command cmd) = cmd ($ def)
  42
  43 -- ** Type 'CommandModifier'
  44 type CommandModifier = ClientRequest -> ClientRequest
  45
  46 instance Cat Command where
  47         Command x <.> Command y = Command $ \k ->
  48                 x $ \fx -> y $ \fy -> k $ fy . fx
  49 instance Alt Command where
  50         Command x <!> Command y = Command $ \k ->
  51                 x k :!: y k
  52         {-
  53         type AltMerge Command = (:!:)
  54         Command x <!> Command y = Command $ \k ->
  55                 x (\cm -> let n:!:_ = k cm in n) :!:
  56                 y (\cm -> let _:!:n = k cm in n)
  57         -}
  58         -- try = id -- FIXME: see what to do
  59 instance Pro Command where
  60         dimap _a2b b2a r = Command $ \k -> unCommand r k . b2a
  61
  62 instance HTTP_Path Command where
  63         segment s  = Command $ \k -> k $ \req ->
  64                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
  65         capture' _n = Command $ \k a -> k $ \req ->
  66                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
  67         captureAll = Command $ \k ss -> k $ \req ->
  68                 req{ clientReqPath =
  69                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
  70                         Web.toUrlPiece <$> ss
  71                  }
  72 instance HTTP_Method Command where
  73         method m = Command $ \k -> k $ \req ->
  74                 req{ clientReqMethod = m }
  75 instance HTTP_Header Command where
  76         header n = Command $ \k v -> k $ \req ->
  77                 req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
  78 instance Web.ToHttpApiData HeaderValue where
  79         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
  80         toHeader = id
  81 instance HTTP_Accept Command where
  82         accept mt = Command $ \k -> k $ \req ->
  83                 req{ clientReqAccept = clientReqAccept req Seq.|> mediaType mt }
  84 instance HTTP_Query Command where
  85         queryParams' n = Command $ \k vs -> k $ \req ->
  86                 req{ clientReqQueryString =
  87                         clientReqQueryString req <>
  88                         fromList ((\v -> (n, Just $ Text.encodeUtf8 $ Web.toQueryParam v)) <$> vs) }
  89         queryFlag n = Command $ \k b -> k $ \req ->
  90                 if b
  91                 then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
  92                 else req
  93 instance HTTP_Version Command where
  94         version v = Command $ \k -> k $ \req ->
  95                 req{clientReqHttpVersion = v}
  96 instance HTTP_Response Command where
  97         type Response    Command = ClientRequest
  98         type ResponseArg Command = ClientRequestType
  99         response' ::
 100          forall repr k mt a.
 101          MimeSerialize mt a =>
 102          MimeUnserialize mt a =>
 103          k ~ Response repr =>
 104          repr ~ Command =>
 105          HTTP.Method ->
 106          repr (ResponseArg repr mt a -> k) k
 107         response' m = Command $ \k ClientRequestType -> k $ \req ->
 108                 req
 109                  { clientReqMethod = m
 110                  , clientReqAccept = clientReqAccept req Seq.|> mediaType (Proxy::Proxy mt)
 111                  }