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_QueryParams 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 instance HTTP_Path Layout where
  79         segment    = layoutOfNode . LayoutNode_Segment
  80         capture'   = layoutOfNode . LayoutNode_Capture
  81         captureAll = layoutOfNode $ LayoutNode_CaptureAll
  82 instance HTTP_Method Layout where
  83         method = layoutOfNode . LayoutNode_Method
  84 instance HTTP_Header Layout where
  85         header = layoutOfNode . LayoutNode_Header
  86 instance HTTP_Accept Layout where
  87         accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
  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 {-
  94 instance HTTP_Response Layout where
  95         response me mt =
  96                 (\(Layout l::Layout (a -> BSL.ByteString)) ->
  97                         Layout l::Layout (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
  98                 ) $
  99                         method me *> accept mt
 100 -}
 101 instance HTTP_Response Layout where
 102         type Response Layout = ()
 103         type ResponseArg Layout = ResponseArgLayout
 104         response' ::
 105          forall repr k mt a.
 106          MimeSerialize mt a =>
 107          MimeUnserialize mt a =>
 108          k ~ Response repr =>
 109          repr ~ Layout =>
 110          HTTP.Method ->
 111          repr (ResponseArg repr mt a -> k) k
 112         response' me = reLayout $ method me <.> accept (Proxy::Proxy mt)
 113 instance HTTP_API Layout
 114 data ResponseArgLayout mt body = ResponseArgLayout