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 instance HTTP_Response Layout where
  91         response me mt =
  92                 (\(Layout l::Layout (a -> BSL.ByteString)) ->
  93                         Layout l::Layout (HTTP.Status -> HTTP.ResponseHeaders -> a -> Wai.Response)
  94                 ) $
  95                         method me *> accept mt
  96 instance HTTP_Endpoint Layout where
  97         type Endpoint Layout = Proxy
  98         endpoint me mt =
  99                 (\(Layout l::Layout (a -> BSL.ByteString)) ->
 100                         Layout l::Layout (Endpoint Layout a)) $
 101                 method me *> accept mt
 102 instance HTTP_API Layout