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 type instance HttpApiData Layout = LayoutHttpApiData
  71 class LayoutHttpApiData a
  72 instance LayoutHttpApiData a
  73 instance Functor (Layout h) where
  74         fmap _f = reLayout
  75 instance Cat Layout where
  76         Layout x <.> Layout y = Layout $ x <> y
  77 instance Alt Layout where
  78         Layout x <!> Layout y =
  79                 Layout [collapseApp x <> collapseApp y]
  80 instance Pro Layout where
  81         dimap _a2b _b2a = reLayout
  82 instance HTTP_Path Layout where
  83         segment    = layoutOfNode . LayoutNode_Segment
  84         capture'   = layoutOfNode . LayoutNode_Capture
  85         captureAll = layoutOfNode $ LayoutNode_CaptureAll
  86 instance HTTP_Header Layout where
  87         header = layoutOfNode . LayoutNode_Header
  88 instance HTTP_Query Layout where
  89         queryParams' = layoutOfNode . LayoutNode_QueryParams
  90         queryFlag    = layoutOfNode . LayoutNode_QueryFlag
  91 instance HTTP_Version Layout where
  92         version = layoutOfNode . LayoutNode_Version
  93 data LayoutBodyArg mt a = LayoutBodyArg
  94 instance HTTP_Body Layout where
  95         type BodyArg Layout = LayoutBodyArg
  96         body' = layoutOfNode $ LayoutNode_Body
  97 data LayoutResponseArg mt a = LayoutResponseArg
  98 instance HTTP_Response Layout where
  99         type Response    Layout = ()
 100         type ResponseArg Layout = LayoutResponseArg
 101         response ::
 102          forall repr k a mt.
 103          MimeSerialize a mt =>
 104          MimeUnserialize a mt =>
 105          k ~ Response repr =>
 106          repr ~ Layout =>
 107          HTTP.Method ->
 108          repr (ResponseArg repr mt a -> k) k
 109         response me =
 110                 reLayout $ method <.> accept
 111                 where
 112                 method = layoutOfNode $ LayoutNode_Method me
 113                 accept = layoutOfNode $ LayoutNode_Accept $ mimeType (Proxy::Proxy mt)
 114 instance HTTP_API Layout