]> Git — Sourcephile - haskell/symantic-http.git/blob - Language/Symantic/HTTP/Layout.hs
Stop here to redesign the API à la sprintf/scanf
[haskell/symantic-http.git] / Language / Symantic / HTTP / Layout.hs
1 {-# LANGUAGE TypeFamilies #-}
2 {-# OPTIONS_GHC -fno-warn-orphans #-}
3 module Language.Symantic.HTTP.Layout where
4
5 import Control.Applicative (Applicative(..))
6 import Data.Eq (Eq(..))
7 import Data.Function (($), (.), id)
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.ByteString.Lazy as BSL
15 import qualified Data.List as List
16 import qualified Network.HTTP.Media as Media
17 import qualified Network.HTTP.Types as HTTP
18 -- import qualified Network.Wai as Wai
19
20 import Language.Symantic.HTTP.Media
21 import Language.Symantic.HTTP.API
22
23 -- * Type 'Layout'
24 newtype Layout a = Layout { unLayout :: App (Alt (Tree LayoutNode)) }
25 -- | Branches of alternatives matches.
26 type Alt = []
27 -- | Keep the path in the 'Tree'
28 -- where to append new matchers;
29 -- in reverse order to simplify appending.
30 type App = []
31
32 runLayout :: Layout a -> Forest String
33 runLayout = ((show <$>) <$>) . collapseApp . unLayout
34
35 instance Show (Layout a) where
36 show = drawForest . runLayout
37
38 reLayout :: Layout a -> Layout b
39 reLayout (Layout l) = Layout l
40
41 -- | Fold 'App' maintained for appending matchers;
42 -- to be done when there is no more appending.
43 collapseApp :: App (Alt (Tree LayoutNode)) -> Alt (Tree LayoutNode)
44 collapseApp = (`List.foldr` []) $ \ts acc ->
45 ((\(Node n ns) -> Node n (ns <> acc)) <$> ts)
46
47 layoutOfNode :: LayoutNode -> Layout a
48 layoutOfNode = Layout . pure . pure . pure
49
50 -- ** Type 'LayoutNode'
51 data LayoutNode
52 = LayoutNode_Segment Segment
53 | LayoutNode_Capture Name
54 | LayoutNode_CaptureAll
55 | LayoutNode_Header HTTP.HeaderName
56 | LayoutNode_Headers HTTP.RequestHeaders
57 | LayoutNode_Query QueryName
58 | LayoutNode_QueryFlag QueryName
59 | LayoutNode_QueryString HTTP.Query
60 | LayoutNode_Method HTTP.Method
61 | LayoutNode_Version HTTP.HttpVersion
62 | LayoutNode_Accept Media.MediaType
63 deriving (Eq, Ord, Show)
64
65 instance Functor Layout where
66 fmap _f = reLayout
67 instance Applicative Layout where
68 pure _ = Layout []
69 Layout x <*> Layout y = Layout $ x <> y
70 instance Altern Layout where
71 tina = Layout []
72 Layout x <+> Layout y =
73 Layout [collapseApp x <> collapseApp y]
74 try = id
75 instance HTTP_Path Layout where
76 segment = layoutOfNode . LayoutNode_Segment
77 capture = layoutOfNode . LayoutNode_Capture
78 captureAll = layoutOfNode $ LayoutNode_CaptureAll
79 instance HTTP_Method Layout where
80 method = layoutOfNode . LayoutNode_Method
81 instance HTTP_Header Layout where
82 header = layoutOfNode . LayoutNode_Header
83 instance HTTP_Accept Layout where
84 accept mt = layoutOfNode $ LayoutNode_Accept (mediaType mt)
85 instance HTTP_Query Layout where
86 query = layoutOfNode . LayoutNode_Query
87 queryFlag = layoutOfNode . LayoutNode_QueryFlag
88 instance HTTP_Version Layout where
89 version = layoutOfNode . LayoutNode_Version
90 {-
91 instance HTTP_Response Layout where
92 response me mt =
93 (\(Layout l::Layout (a -> BSL.ByteString)) ->
94 Layout l::Layout (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
95 ) $
96 method me *> accept mt
97 -}
98 instance HTTP_Endpoint Layout where
99 type Endpoint Layout = Proxy
100 endpoint me mt =
101 (\(Layout l::Layout (a -> BSL.ByteString)) ->
102 Layout l::Layout (Endpoint Layout a)) $
103 method me *> accept mt
104 instance HTTP_API Layout