]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/Layout.hs
Drop the Language prefix in module names
[haskell/symantic-http.git] / 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 Appli Layout where
74 Layout x <.> Layout y = Layout $ x <> y
75 instance Altern 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