Symantic/HTTP/Layout.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Symantic.HTTP.Layout where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Data.Eq (Eq(..))
   6 import Data.Function (($), (.), id)
   7 import Data.Functor (Functor(..), (<$>))
   8 import Data.Ord (Ord(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.String (String)
  11 import Data.Tree (Tree(..), Forest, drawForest)
  12 import Text.Show (Show(..))
  13 import qualified Data.List as List
  14 import qualified Network.HTTP.Types as HTTP
  15
  16 import Symantic.HTTP.MIME
  17 import Symantic.HTTP.API
  18
  19 -- * Type 'Layout'
  20 newtype Layout h k = Layout { unLayout :: LayoutApp (LayoutAlt (Tree LayoutNode)) }
  21 -- | Branches of alternatives matches.
  22 type LayoutAlt = []
  23 -- | Keep the path in the 'Tree'
  24 -- where to append new matchers;
  25 -- in reverse order to simplify appending.
  26 type LayoutApp = []
  27
  28 -- | Useful to constrain 'repr' to be 'Layout'.
  29 layout :: Layout h k -> Layout h k
  30 layout = id
  31
  32 runLayout :: Layout h k -> Forest String
  33 runLayout = ((show <$>) <$>) . collapseApp . unLayout
  34
  35 instance Show (Layout h k) where
  36         show = drawForest . runLayout
  37
  38 reLayout :: Layout h k -> Layout h' k'
  39 reLayout (Layout l) = Layout l
  40
  41 -- | Fold 'LayoutApp' maintained for appending matchers;
  42 -- to be done when there is no more appending.
  43 collapseApp :: LayoutApp (LayoutAlt (Tree LayoutNode)) -> LayoutAlt (Tree LayoutNode)
  44 collapseApp = (`List.foldr` []) $ \ts acc ->
  45         ((\(Node n ns) -> Node n (ns <> acc)) <$> ts)
  46
  47 layoutOfNode :: LayoutNode -> Layout h k
  48 layoutOfNode = Layout . pure . pure . pure
  49
  50 -- ** Type 'LayoutNode'
  51 data LayoutNode
  52  =   LayoutNode_Accept      MediaTypes
  53  |   LayoutNode_Body        MediaTypes
  54  |   LayoutNode_BodyStream
  55  |   LayoutNode_BasicAuth   BasicAuthRealm
  56  |   LayoutNode_Capture     Name
  57  |   LayoutNode_CaptureAll
  58  |   LayoutNode_Header      HTTP.HeaderName
  59  |   LayoutNode_Headers     HTTP.RequestHeaders
  60  |   LayoutNode_Method      HTTP.Method
  61  |   LayoutNode_QueryFlag   QueryName
  62  |   LayoutNode_QueryParams QueryName
  63  |   LayoutNode_QueryString HTTP.Query
  64  |   LayoutNode_Segment     Segment
  65  |   LayoutNode_Version     HTTP.HttpVersion
  66  deriving (Eq, Ord, Show)
  67
  68 instance Functor (Layout h) where
  69         fmap _f = reLayout
  70 instance Cat Layout where
  71         Layout x <.> Layout y = Layout $ x <> y
  72 instance Alt Layout where
  73         Layout x <!> Layout y =
  74                 Layout [collapseApp x <> collapseApp y]
  75 instance Pro Layout where
  76         dimap _a2b _b2a = reLayout
  77 instance HTTP_Path Layout where
  78         segment    = layoutOfNode . LayoutNode_Segment
  79         capture'   = layoutOfNode . LayoutNode_Capture
  80         captureAll = layoutOfNode $ LayoutNode_CaptureAll
  81 instance HTTP_Header Layout where
  82         header = layoutOfNode . LayoutNode_Header
  83 instance HTTP_BasicAuth Layout where
  84         type BasicAuthArgs Layout a k = k
  85         basicAuth' = layoutOfNode . LayoutNode_BasicAuth
  86 instance HTTP_Query Layout where
  87         queryParams' = layoutOfNode . LayoutNode_QueryParams
  88         queryFlag    = layoutOfNode . LayoutNode_QueryFlag
  89 instance HTTP_Version Layout where
  90         version = layoutOfNode . LayoutNode_Version
  91 data LayoutBodyArg a (ts::[*]) = LayoutBodyArg
  92 instance HTTP_Body Layout where
  93         type BodyConstraint Layout a ts = MimeTypes ts (MimeDecodable a)
  94         type BodyArg Layout a ts = LayoutBodyArg a ts
  95         body' ::
  96          forall a ts k repr.
  97          BodyConstraint repr a ts =>
  98          repr ~ Layout =>
  99          repr (BodyArg repr a ts -> k) k
 100         body' = layoutOfNode $ LayoutNode_Body $ mediaTypes @ts @(MimeDecodable a)
 101 data LayoutBodyStreamArg framing (ts::[*]) as = LayoutBodyStreamArg
 102 instance HTTP_BodyStream Layout where
 103         type BodyStreamConstraint Layout as ts framing =
 104          MimeTypes ts (MimeDecodable (FramingYield as))
 105         type BodyStreamArg Layout as ts framing =
 106          LayoutBodyStreamArg framing ts as
 107         bodyStream' ::
 108          forall as ts framing k repr.
 109          BodyStreamConstraint repr as ts framing =>
 110          repr ~ Layout =>
 111          repr (BodyStreamArg repr as ts framing -> k) k
 112         bodyStream' = layoutOfNode $ LayoutNode_BodyStream
 113 data LayoutResponseArgs a (ts::[*]) = LayoutResponseArgs
 114 instance HTTP_Response Layout where
 115         type ResponseConstraint Layout a ts = MimeTypes ts (MimeEncodable a)
 116         type ResponseArgs Layout a ts = LayoutResponseArgs a ts
 117         type Response Layout = ()
 118         response ::
 119          forall a ts repr.
 120          ResponseConstraint repr a ts =>
 121          repr ~ Layout =>
 122          HTTP.Method ->
 123          repr (ResponseArgs repr a ts)
 124               (Response repr)
 125         response me =
 126                 reLayout $ method <.> accept
 127                 where
 128                 method = layoutOfNode $ LayoutNode_Method me
 129                 accept = layoutOfNode $ LayoutNode_Accept $ mediaTypes @ts @(MimeEncodable a)
 130 instance HTTP_API Layout