]> Git — Sourcephile - haskell/symantic-http.git/blob - symantic-http-doc/Symantic/HTTP/Layout.hs
stack: bump to lts-14.13
[haskell/symantic-http.git] / symantic-http-doc / 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.Semigroup (Semigroup(..))
10 import Data.String (String)
11 import Data.Tree (Tree(..), Forest, drawForest)
12 import Text.Show (Show(..))
13 import qualified Data.List as List
14 import qualified Network.HTTP.Types as HTTP
15
16 import Symantic.HTTP.MIME
17 import Symantic.HTTP.API
18
19 -- * Type 'Layout'
20 newtype Layout h k = Layout { unLayout :: LayoutApp (LayoutAlt (Tree LayoutNode)) }
21 -- | Branches of alternatives matches.
22 type LayoutAlt = []
23 -- | Keep the path in the 'Tree'
24 -- where to append new matchers;
25 -- in reverse order to simplify appending.
26 type LayoutApp = []
27
28 -- | Useful to constrain 'repr' to be 'Layout'.
29 layout :: Layout h k -> Layout h k
30 layout = id
31
32 runLayout :: Layout h k -> Forest String
33 runLayout = ((show <$>) <$>) . collapseApp . unLayout
34
35 instance Show (Layout h k) where
36 show = drawForest . runLayout
37
38 reLayout :: Layout h k -> Layout h' k'
39 reLayout (Layout l) = Layout l
40
41 -- | Fold 'LayoutApp' maintained for appending matchers;
42 -- to be done when there is no more appending.
43 collapseApp :: LayoutApp (LayoutAlt (Tree LayoutNode)) -> LayoutAlt (Tree LayoutNode)
44 collapseApp = (`List.foldr` []) $ \ts acc ->
45 ((\(Node n ns) -> Node n (ns <> acc)) <$> ts)
46
47 layoutOfNode :: LayoutNode -> Layout h k
48 layoutOfNode = Layout . pure . pure . pure
49
50 -- ** Type 'LayoutNode'
51 data LayoutNode
52 = LayoutNode_Accept MediaTypes
53 | LayoutNode_Body MediaTypes
54 | LayoutNode_BodyStream
55 | LayoutNode_BasicAuth BasicAuthRealm
56 | LayoutNode_Capture Name
57 | LayoutNode_CaptureAll
58 | LayoutNode_Header HTTP.HeaderName
59 | LayoutNode_Headers HTTP.RequestHeaders
60 | LayoutNode_Method HTTP.Method
61 | LayoutNode_QueryFlag QueryName
62 | LayoutNode_QueryParams QueryName
63 | LayoutNode_QueryString HTTP.Query
64 | LayoutNode_Segment Segment
65 | LayoutNode_Version HTTP.HttpVersion
66 deriving (Eq, Ord, Show)
67
68 instance Functor (Layout h) where
69 fmap _f = reLayout
70 instance Cat Layout where
71 Layout x <.> Layout y = Layout $ x <> y
72 instance Alt Layout where
73 Layout x <!> Layout y =
74 Layout [collapseApp x <> collapseApp y]
75 instance Pro Layout where
76 dimap _a2b _b2a = reLayout
77 instance HTTP_Path Layout where
78 segment = layoutOfNode . LayoutNode_Segment
79 capture' = layoutOfNode . LayoutNode_Capture
80 captureAll = layoutOfNode $ LayoutNode_CaptureAll
81 instance HTTP_Header Layout where
82 header = layoutOfNode . LayoutNode_Header
83 instance HTTP_BasicAuth Layout where
84 type BasicAuthArgs Layout a k = k
85 basicAuth' = layoutOfNode . LayoutNode_BasicAuth
86 instance HTTP_Query Layout where
87 queryParams' = layoutOfNode . LayoutNode_QueryParams
88 queryFlag = layoutOfNode . LayoutNode_QueryFlag
89 instance HTTP_Version Layout where
90 version = layoutOfNode . LayoutNode_Version
91 data LayoutBodyArg a (ts::[*]) = LayoutBodyArg
92 instance HTTP_Body Layout where
93 type BodyConstraint Layout a ts = MimeTypes ts (MimeDecodable a)
94 type BodyArg Layout a ts = LayoutBodyArg a ts
95 body' ::
96 forall a ts k repr.
97 BodyConstraint repr a ts =>
98 repr ~ Layout =>
99 repr (BodyArg repr a ts -> k) k
100 body' = layoutOfNode $ LayoutNode_Body $ mediaTypes @ts @(MimeDecodable a)
101 data LayoutBodyStreamArg framing (ts::[*]) as = LayoutBodyStreamArg
102 instance HTTP_BodyStream Layout where
103 type BodyStreamConstraint Layout as ts framing =
104 MimeTypes ts (MimeDecodable (FramingYield as))
105 type BodyStreamArg Layout as ts framing =
106 LayoutBodyStreamArg framing ts as
107 bodyStream' ::
108 forall as ts framing k repr.
109 BodyStreamConstraint repr as ts framing =>
110 repr ~ Layout =>
111 repr (BodyStreamArg repr as ts framing -> k) k
112 bodyStream' = layoutOfNode $ LayoutNode_BodyStream
113 data LayoutResponseArgs a (ts::[*]) = LayoutResponseArgs
114 instance HTTP_Response Layout where
115 type ResponseConstraint Layout a ts = MimeTypes ts (MimeEncodable a)
116 type ResponseArgs Layout a ts = LayoutResponseArgs a ts
117 type Response Layout = ()
118 response ::
119 forall a ts repr.
120 ResponseConstraint repr a ts =>
121 repr ~ Layout =>
122 HTTP.Method ->
123 repr (ResponseArgs repr a ts)
124 (Response repr)
125 response me =
126 reLayout $ method <.> accept
127 where
128 method = layoutOfNode $ LayoutNode_Method me
129 accept = layoutOfNode $ LayoutNode_Accept $ mediaTypes @ts @(MimeEncodable a)