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