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 -- import qualified Network.Wai as Wai
  20
  21 import Symantic.HTTP.Media
  22 import Symantic.HTTP.Mime
  23 import Symantic.HTTP.API
  24
  25 -- * Type 'Layout'
  26 newtype Layout h k = Layout { unLayout :: LayoutApp (LayoutAlt (Tree LayoutNode)) }
  27 -- | Branches of alternatives matches.
  28 type LayoutAlt = []
  29 -- | Keep the path in the 'Tree'
  30 -- where to append new matchers;
  31 -- in reverse order to simplify appending.
  32 type LayoutApp = []
  33
  34 -- | Useful to constrain 'repr' to be 'Layout'.
  35 layout :: Layout h k -> Layout h k
  36 layout = id
  37
  38 runLayout :: Layout h k -> Forest String
  39 runLayout = ((show <$>) <$>) . collapseApp . unLayout
  40
  41 instance Show (Layout h k) where
  42         show = drawForest . runLayout
  43
  44 reLayout :: Layout h k -> Layout h' k'
  45 reLayout (Layout l) = Layout l
  46
  47 -- | Fold 'LayoutApp' maintained for appending matchers;
  48 -- to be done when there is no more appending.
  49 collapseApp :: LayoutApp (LayoutAlt (Tree LayoutNode)) -> LayoutAlt (Tree LayoutNode)
  50 collapseApp = (`List.foldr` []) $ \ts acc ->
  51         ((\(Node n ns) -> Node n (ns <> acc)) <$> ts)
  52
  53 layoutOfNode :: LayoutNode -> Layout h k
  54 layoutOfNode = Layout . pure . pure . pure
  55
  56 -- ** Type 'LayoutNode'
  57 data LayoutNode
  58  =   LayoutNode_Segment     Segment
  59  |   LayoutNode_Capture     Name
  60  |   LayoutNode_CaptureAll
  61  |   LayoutNode_Header      HTTP.HeaderName
  62  |   LayoutNode_Headers     HTTP.RequestHeaders
  63  |   LayoutNode_Query       QueryName
  64  |   LayoutNode_QueryFlag   QueryName
  65  |   LayoutNode_QueryString HTTP.Query
  66  |   LayoutNode_Method      HTTP.Method
  67  |   LayoutNode_Version     HTTP.HttpVersion
  68  |   LayoutNode_Accept      Media.MediaType
  69  deriving (Eq, Ord, Show)
  70
  71 instance Functor (Layout h) where
  72         fmap _f = reLayout
  73 instance Cat Layout where
  74         Layout x <.> Layout y = Layout $ x <> y
  75 instance Alt Layout where
  76         Layout x <!> Layout y =
  77                 Layout [collapseApp x <> collapseApp y]
  78         try = id
  79 instance HTTP_Path Layout where
  80         segment    = layoutOfNode . LayoutNode_Segment
  81         capture'   = layoutOfNode . LayoutNode_Capture
  82         captureAll = layoutOfNode $ LayoutNode_CaptureAll
  83 instance HTTP_Method Layout where
  84         method = layoutOfNode . LayoutNode_Method
  85 instance HTTP_Header Layout where
  86         header = layoutOfNode . LayoutNode_Header
  87 instance HTTP_Accept Layout where
  88         accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
  89 instance HTTP_Query Layout where
  90         query'    = layoutOfNode . LayoutNode_Query
  91         queryFlag = layoutOfNode . LayoutNode_QueryFlag
  92 instance HTTP_Version Layout where
  93         version = layoutOfNode . LayoutNode_Version
  94 {-
  95 instance HTTP_Response Layout where
  96         response me mt =
  97                 (\(Layout l::Layout (a -> BSL.ByteString)) ->
  98                         Layout l::Layout (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
  99                 ) $
 100                         method me *> accept mt
 101 -}
 102 instance HTTP_Endpoint Layout where
 103         type Endpoint Layout = ()
 104         type EndpointArg Layout = EndpointArgLayout
 105         endpoint' ::
 106          forall repr k mt a.
 107          MimeSerialize mt a =>
 108          MimeUnserialize mt a =>
 109          k ~ Endpoint repr =>
 110          repr ~ Layout =>
 111          HTTP.Method ->
 112          repr (EndpointArg repr mt a -> k) k
 113         endpoint' me = reLayout $ method me <.> accept (Proxy::Proxy mt)
 114 instance HTTP_API Layout
 115 data EndpointArgLayout mt body = EndpointArgLayout