Symantic/HTTP/Layout.hs

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