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
  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 =
  85                         clientReqQueryString req <>
  86                         fromList ((\v -> (n, Text.encodeUtf8 . Web.toQueryParam <$> v)) <$> vs) }
  87         queryFlag n = Command $ \k b -> k $ \req ->
  88                 if b
  89                 then req{ clientReqQueryString = clientReqQueryString req Seq.|> (n, Nothing) }
  90                 else req
  91 instance HTTP_Version Command where
  92         version v = Command $ \k -> k $ \req ->
  93                 req{clientReqHttpVersion = v}
  94 instance HTTP_Endpoint Command where
  95         type Endpoint    Command = ClientRequest
  96         type EndpointArg Command = ClientRequestType
  97         endpoint' ::
  98          forall repr k mt a.
  99          MimeSerialize mt a =>
 100          MimeUnserialize mt a =>
 101          k ~ Endpoint repr =>
 102          repr ~ Command =>
 103          HTTP.Method ->
 104          repr (EndpointArg repr mt a -> k) k
 105         endpoint' m = Command $ \k ClientRequestType -> k $ \req ->
 106                 req
 107                  { clientReqMethod = m
 108                  , clientReqAccept = clientReqAccept req Seq.|> mediaType (Proxy::Proxy mt)
 109                  }