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