module Web.Haskyapi.Header (
parse,
RqLine(..),
Header(..),
pprint,
Method(..),
Query,
Body,
Endpoint,
Api,
ApiFunc,
ContentType(..),
toCType,
Domain,
SubDomain,
) where
import qualified Data.ByteString.Char8 as C
import qualified Data.List.Split as S
import qualified Data.List as L
import Data.List.Split (splitOn)
import Data.Maybe
import Control.Monad
import Debug.Trace (trace)
type Domain = String
type SubDomain = [(String, String)]
type Api = (Method, Endpoint, ApiFunc, ContentType)
type ApiFunc = Query -> Body -> IO String
type Body = String
type Query = [(String, String)]
type Endpoint = String
data Method = GET
| POST
| PUT
| DELETE
| PATCH
| Other
deriving (Show, Eq)
toMethod :: String -> Method
toMethod "GET" = GET
toMethod "POST" = POST
toMethod "PUT" = PUT
toMethod "DELETE" = DELETE
toMethod "PATCH" = PATCH
toMethod _ = Other
data RqLine = RqLine {
method :: Method,
target :: String,
parameters :: Query
} deriving (Show, Eq)
data Header = Header {
hRqLine :: RqLine,
hHost :: Maybe String,
hUserAgent :: Maybe String,
hAccept :: Maybe String,
hContentLength :: Maybe String,
hContentType :: Maybe String,
hReferer :: Maybe String
} deriving (Eq)
pprint :: Header -> IO ()
pprint hdr = putStr $ L.intercalate "\n" [
"RequestLine -> " ++ show (hRqLine hdr),
"Host -> " ++ maybe "nothing" show (hHost hdr),
"UserAgent -> " ++ maybe "nothing" show (hUserAgent hdr),
"Accept -> " ++ maybe "nothing" show (hAccept hdr),
"ContentLength -> " ++ maybe "nothing" show (hContentLength hdr),
"ContentType -> " ++ maybe "nothing" show (hContentType hdr),
"Referer -> " ++ maybe "nothing" show (hReferer hdr)
]
instance Show Header where
show hdr = unwords [
"[RequestLine: " ++ rqLine2Str (hRqLine hdr) ++ "]",
"[Host: " ++ maybe "nothing" show (hHost hdr) ++ "]",
"[UserAgent: " ++ maybe "nothing" show (hUserAgent hdr) ++ "]",
"[Accept: " ++ maybe "nothing" show (hAccept hdr) ++ "]",
"[ContentLength: " ++ maybe "nothing" show (hContentLength hdr) ++ "]",
"[ContentType: " ++ maybe "nothing" show (hContentType hdr) ++ "]",
"[Referer: " ++ maybe "nothing" show (hReferer hdr) ++ "]"
]
where
rqLine2Str (RqLine m s q) = unwords [ show m, s, show q ]
unitheader :: Header
unitheader = Header {
hRqLine = RqLine GET "/" [],
hHost = Nothing,
hUserAgent = Nothing,
hAccept = Nothing,
hContentLength = Nothing,
hContentType = Nothing,
hReferer = Nothing
}
mkqry :: String -> (Endpoint, Query)
mkqry tmp =
let ep:qry' = S.splitOneOf "?&" tmp
qry = map (qsplit "") qry'
in (ep, qry)
qsplit :: String -> String -> (String, String)
qsplit key "" = ("", "")
qsplit key (c:cs)
| c == '=' = (key, cs)
| otherwise = qsplit (key++[c]) cs
parseRqLine :: String -> Header -> Header
parseRqLine str hdr =
let mtd':tmp:_ = words str
(ep,qry) = mkqry tmp
mtd = RqLine {method=toMethod mtd', target=ep, parameters=qry}
in hdr { hRqLine = mtd }
parse :: [String] -> Header
parse [] = unitheader
parse (x:xs) =
let firstheader = parseRqLine x unitheader in
foldl str2h firstheader xs
where
str2h hdr "" = hdr
str2h hdr str =
let key:rest = words str in
case key of
"Host:" -> hdr { hHost = Just (head rest) }
"User-Agent:" -> hdr { hUserAgent = Just (head rest) }
"Accept:" -> hdr { hAccept = Just (head rest) }
"Content-Length:" -> hdr { hContentLength = Just (head rest) }
"Content-Type:" -> hdr { hContentType = Just (head rest) }
"Referer:" -> hdr { hReferer = Just (head rest) }
_ -> hdr
data ContentType = Chtml
| Ccss
| Cjs
| Cjson
| Cplain
| Cjpeg
| Cpng
| Cgif
| Cpdf
| Cmarkdown
deriving (Eq)
instance Show ContentType where
show Cmarkdown = show Chtml
show Chtml = "text/html"
show Ccss = "text/css"
show Cjs = "text/javascript"
show Cplain = "text/plain"
show Cjpeg = "image/jpeg"
show Cpng = "image/png"
show Cgif = "image/gif"
show Cpdf = "application/pdf"
show Cjson = "application/json"
toCType :: String -> ContentType
toCType "html" = Chtml
toCType "htm" = Chtml
toCType "md" = Cmarkdown
toCType "css" = Ccss
toCType "js" = Cjs
toCType "plain" = Cplain
toCType "jpeg" = Cjpeg
toCType "png" = Cpng
toCType "gif" = Cgif
toCType "pdf" = Cpdf
toCType "txt" = Cplain
toCType "text" = Cplain
toCType "json" = Cjson
toCType _ = Cplain