Language/Symantic/HTTP/Command.hs

   1 {-# LANGUAGE InstanceSigs #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeFamilies #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Language.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 Language.Symantic.HTTP.Media
  22 import Language.Symantic.HTTP.API
  23 import Language.Symantic.HTTP.Client
  24 import Language.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 Appli Command where
  47         Command x <.> Command y = Command $ \k ->
  48                 x $ \fx -> y $ \fy -> k $ fy . fx
  49 instance Altern Command where
  50         Command x <!> Command y = Command $ \k ->
  51                 x k :!: y k
  52         {-
  53         type AlternMerge 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
  60 instance HTTP_Path Command where
  61         segment s  = Command $ \k -> k $ \req ->
  62                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece s }
  63         capture' _n = Command $ \k a -> k $ \req ->
  64                 req{ clientReqPath = clientReqPath req <> "/" <> Web.toEncodedUrlPiece a }
  65         captureAll = Command $ \k ss -> k $ \req ->
  66                 req{ clientReqPath =
  67                         List.foldl' (\acc s -> acc <> "/" <> Web.toEncodedUrlPiece s) "" $
  68                         Web.toUrlPiece <$> ss
  69                  }
  70 instance HTTP_Method Command where
  71         method m = Command $ \k -> k $ \req ->
  72                 req{ clientReqMethod = m }
  73 instance HTTP_Header Command where
  74         header n = Command $ \k v -> k $ \req ->
  75                 req{ clientReqHeaders = clientReqHeaders req Seq.|> (n, Web.toHeader v) }
  76 instance Web.ToHttpApiData HeaderValue where
  77         toUrlPiece = Web.toUrlPiece . Text.decodeUtf8
  78         toHeader = id
  79 instance HTTP_Accept Command where
  80         accept mt = Command $ \k -> k $ \req ->
  81                 req{ clientReqAccept = clientReqAccept req Seq.|> mediaType mt }
  82 instance HTTP_Query Command where
  83         query n = Command $ \k vs -> k $ \req ->
  84                 req{ clientReqQueryString = clientReqQueryString req <> fromList ((n,) <$> vs) }
  85         queryFlag n = Command $ \k b -> k $ \req ->
  86                 if b
  87                 then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
  88                 else req
  89 instance HTTP_Version Command where
  90         version v = Command $ \k -> k $ \req ->
  91                 req{clientReqHttpVersion = v}
  92 instance HTTP_Endpoint Command where
  93         type Endpoint    Command = ClientRequest
  94         type EndpointArg Command = ClientRequestType
  95         endpoint' ::
  96          forall repr k mt a.
  97          MimeSerialize mt a =>
  98          MimeUnserialize mt a =>
  99          k ~ Endpoint repr =>
 100          repr ~ Command =>
 101          HTTP.Method ->
 102          repr (EndpointArg repr mt a -> k) k
 103         endpoint' m = Command $ \k ClientRequestType -> k $ \req ->
 104                 req
 105                  { clientReqMethod = m
 106                  , clientReqAccept = clientReqAccept req Seq.|> mediaType (Proxy::Proxy mt)
 107                  }