Language/Symantic/HTTP.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE NoMonomorphismRestriction #-}
   3 {-# LANGUAGE StrictData #-}
   4 {-# LANGUAGE TypeApplications #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Language.Symantic.HTTP
   8  ( module Language.Symantic.HTTP
   9  , module Language.Symantic.HTTP.API
  10  , module Language.Symantic.HTTP.Layout
  11  , module Language.Symantic.HTTP.Media
  12  , module Language.Symantic.HTTP.Router
  13  ) where
  14
  15 -- import qualified Data.ByteString.Lazy as BSL
  16 import Control.Applicative (Applicative(..))
  17 import Control.Monad ()
  18 import Data.Bool
  19 import Data.Either (Either(..))
  20 import Data.Function (($))
  21 import Data.Functor ((<$>), (<$))
  22 import Data.Maybe (Maybe(..))
  23 import Data.Proxy (Proxy(..))
  24 import Data.Semigroup (Semigroup(..))
  25 import Data.String (IsString(..))
  26 import System.IO (IO)
  27 import Prelude (error)
  28 import Text.Show (Show(..))
  29 import qualified Data.Text as Text
  30 import qualified Data.Time as Time
  31 import qualified Network.HTTP.Media as Media
  32 import qualified Network.HTTP.Types as HTTP
  33 import qualified Network.HTTP.Types.Header as HTTP
  34 import qualified Network.Wai as Wai
  35 import qualified Network.Wai.Handler.Warp as Warp
  36
  37 import Language.Symantic.HTTP.API
  38 import Language.Symantic.HTTP.Media
  39 import Language.Symantic.HTTP.Router
  40 import Language.Symantic.HTTP.Layout
  41
  42 -- * Type 'API0'
  43 data API0
  44  =   API0_Date Time.Day
  45  |   API0_Time Time.ZonedTime
  46  |   API0_Reset Bool
  47  deriving (Show)
  48 instance IsString Time.TimeZone where
  49         fromString s = case s of
  50          "CEST" -> Time.TimeZone 2 True "CEST"
  51          "CET"  -> Time.TimeZone 1 False "CET"
  52          _ -> error "unknown TimeZone"
  53
  54
  55 api0 :: HTTP_API repr => repr ()
  56 api0 =
  57         () <$ method_GET <+>
  58         () <$ method_POST
  59
  60 api00 :: HTTP_API repr => repr ()
  61 api00 =
  62         () <$ method_GET <+>
  63         () <$ method_POST <+>
  64         () <$ method_HEAD
  65
  66 api000 :: HTTP_API repr => repr ()
  67 api000 =
  68         () <$ method_GET <+>
  69         () <$ method_POST <+>
  70         () <$ method_HEAD <+>
  71         () <$ method_PUT
  72
  73 api1 f0 f1 =
  74         f0
  75          <$  segment "time"
  76          <*> capture "timezone"
  77          <*> endpoint HTTP.methodGet plainText <+>
  78         f1
  79          <$  segment "date"
  80          <*> endpoint HTTP.methodGet plainText
  81
  82 lay1 :: Layout ()
  83 lay1 = api1
  84         (\_tz (Proxy::Proxy ()) -> ())
  85         (\(Proxy::Proxy ()) -> ())
  86
  87 rou1 :: Router Application
  88 rou1 = api1
  89         (\tz (RouterEndpoint respond) _rq re -> do
  90                 time <- Time.utcToZonedTime (fromString $ Text.unpack tz) <$> Time.getCurrentTime
  91                 re $ Right $ respond (HTTP.mkStatus 200 "") [] $ show time <> "\n")
  92         (\(RouterEndpoint respond) _rq re -> do
  93                 date <- Time.utctDay <$> Time.getCurrentTime
  94                 re $ Right $ respond (HTTP.mkStatus 200 "") [] $ show date <> "\n")
  95
  96 srv1 :: IO ()
  97 srv1 = Warp.run 8080 $ runRouterApp rou1
  98 {-
  99 api2 :: HTTP_API repr => repr Application
 100 api2 =
 101         (\too respond _rq re ->
 102                 re $ Right $ respond (HTTP.mkStatus 200 "") [] too)
 103          <$  segment "me"
 104          <*> capture "too"
 105          <*> endpoint HTTP.methodGet plainText
 106
 107 api3 f = f <$ segment "me" <*> capture "too" <*> capture "too"
 108 -}
 109
 110 req1_1 :: Wai.Request
 111 req1_1 = Wai.defaultRequest
 112  { Wai.requestMethod  = HTTP.methodGet
 113  , Wai.pathInfo       = ["date"]
 114  , Wai.requestHeaders =
 115     [ (HTTP.hAccept, Media.renderHeader $ mediaType plainText) ]
 116  }
 117
 118 req1_2 :: Wai.Request
 119 req1_2 = Wai.defaultRequest
 120  { Wai.requestMethod  = HTTP.methodGet
 121  , Wai.pathInfo       = ["time", "CEST"]
 122  , Wai.requestHeaders =
 123     [ (HTTP.hAccept, Media.renderHeader $ mediaType plainText) ]
 124  }
 125
 126 req1_3 :: Wai.Request
 127 req1_3 = Wai.defaultRequest
 128  { Wai.requestMethod  = HTTP.methodPost
 129  , Wai.pathInfo       = ["clock"]
 130  , Wai.queryString =
 131     [ ("reset", Just "1") ]
 132  }
 133
 134 req1_KO_1 :: Wai.Request
 135 req1_KO_1 = Wai.defaultRequest
 136  { Wai.requestMethod  = HTTP.methodPut
 137  , Wai.pathInfo       = ["time", "CEST"]
 138  , Wai.requestHeaders =
 139     [ (HTTP.hAccept, Media.renderHeader $ mediaType plainText) ]
 140  }
 141
 142 req1_KO_2 :: Wai.Request
 143 req1_KO_2 = Wai.defaultRequest
 144  { Wai.requestMethod  = HTTP.methodGet
 145  , Wai.pathInfo       = ["non-existent"]
 146  , Wai.requestHeaders =
 147     [ (HTTP.hAccept, Media.renderHeader $ mediaType plainText) ]
 148  }
 149
 150 req1_KO_3 :: Wai.Request
 151 req1_KO_3 = Wai.defaultRequest
 152  { Wai.requestMethod  = HTTP.methodGet
 153  , Wai.pathInfo       = ["date"]
 154  , Wai.requestHeaders =
 155     [ (HTTP.hAccept, "application/non-sense") ]
 156  }
 157
 158 req1_KO_4 :: Wai.Request
 159 req1_KO_4 = Wai.defaultRequest
 160  { Wai.requestMethod  = HTTP.methodGet
 161  , Wai.pathInfo       = ["date"]
 162  , Wai.requestHeaders =
 163     [ (HTTP.hHost, "example.com") ]
 164  }
 165
 166 req1_KO_5 :: Wai.Request
 167 req1_KO_5 = Wai.defaultRequest
 168  { Wai.requestMethod  = HTTP.methodPost
 169  , Wai.pathInfo       = ["clock"]
 170  , Wai.queryString =
 171     [ ("reset", Just "NaN") ]
 172  }
 173
 174 {-
 175 test :: IO ()
 176 test = do
 177         forM_
 178          [ req1_1, req1_2, req1_3
 179          , req1_KO_1, req1_KO_2, req1_KO_3, req1_KO_4, req1_KO_5
 180          ] $ \req -> do
 181                 runRouterIO api1 req
 182 -}