-- |
-- Module: Network.Shed.Httpd 
-- Copyright: Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: GHC
--
--
-- A trivial web server.
--
-- This web server promotes a Request to IO Response function
-- into a local web server. The user can decide how to interpret
-- the requests, and the library is intended for implementing Ajax APIs.
--
-- initServerLazy (and assocated refactorings), and Chunking support
-- was written by Henning Thielemann.
-- Handling of POST-based payloads was been written by Brandon Moore.
-- initServerBind support was written by John Van Enk.

{-# LANGUAGE CPP #-}
module Network.Shed.Httpd 
    ( Server
    , initServer
    , initServerLazy
    , initServerBind
    , initServerLazyBind
    , Request(..)
    , Response(..)
    , queryToArguments
    , addCache
    , noCache
    , contentType
    ) where

import qualified Network.Socket as Socket
import Network.URI (URI, parseURIReference, unEscapeString)
import Network.BSD (getProtocolNumber)
#if MIN_VERSION_network(3,0,0)
#else
import Network.Socket (iNADDR_ANY)
#endif
import Network.Socket (
          SockAddr(SockAddrInet),
          setSocketOption, socket)

import Control.Concurrent (forkIO)
import Control.Exception (finally)

import System.IO (Handle, hPutStr, hClose, hGetLine, hGetContents, IOMode(..))

import qualified Data.Char as Char
import Numeric (showHex)


#if MIN_VERSION_network(3,0,0)
iNADDR_ANY :: Socket.HostAddress
iNADDR_ANY :: HostAddress
iNADDR_ANY = (Word8, Word8, Word8, Word8) -> HostAddress
Socket.tupleToHostAddress (Word8
0,Word8
0,Word8
0,Word8
0)
#endif

type Server = () -- later, we might have a handle for shutting down a server.

{- |
This server transfers documents as one parcel, using the content-length header.
-}

initServer
   :: Int                       -- ^ The port number
   -> (Request -> IO Response)  -- ^ The functionality of the Server
   -> IO Server                 -- ^ A token for the Server
initServer :: Int -> (Request -> IO Response) -> IO Server
initServer Int
port =
  (String -> ([(String, String)], String))
-> SockAddr -> (Request -> IO Response) -> IO Server
initServerMain
     (\String
body -> ([(String
"Content-Length", Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
body))], String
body))
     (PortNumber -> HostAddress -> SockAddr
SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) HostAddress
iNADDR_ANY)

{- |
This server transfers documents in chunked mode
and without content-length header.
This way you can ship infinitely big documents.
It inserts the transfer encoding header for you.
The server binds to all interfaces
-}
initServerLazy
   :: Int                       -- ^ Chunk size
   -> Int                       -- ^ The port number
   -> (Request -> IO Response)  -- ^ The functionality of the Server
   -> IO Server                 -- ^ A token for the Server
initServerLazy :: Int -> Int -> (Request -> IO Response) -> IO Server
initServerLazy Int
chunkSize Int
port =
  Int -> Int -> HostAddress -> (Request -> IO Response) -> IO Server
initServerLazyBind Int
chunkSize Int
port HostAddress
iNADDR_ANY

{- |
This server transfers documents in chunked mode
and without content-length header.
This way you can ship infinitely big documents.
It inserts the transfer encoding header for you.
The server binds to the specified address.
-}
initServerLazyBind
   :: Int                       -- ^ Chunk size
   -> Int                       -- ^ The port number
   -> Socket.HostAddress        -- ^ The host address
   -> (Request -> IO Response)  -- ^ The functionality of the Server
   -> IO Server                 -- ^ A token for the Server
initServerLazyBind :: Int -> Int -> HostAddress -> (Request -> IO Response) -> IO Server
initServerLazyBind Int
chunkSize Int
port HostAddress
addr =
  (String -> ([(String, String)], String))
-> SockAddr -> (Request -> IO Response) -> IO Server
initServerMain
     (\String
body ->
        ([(String
"Transfer-Encoding", String
"chunked")],
         ((String -> String) -> String -> String)
-> String -> [String -> String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
($) String
"" ([String -> String] -> String) -> [String -> String] -> String
forall a b. (a -> b) -> a -> b
$
         (String -> String -> String) -> [String] -> [String -> String]
forall a b. (a -> b) -> [a] -> [b]
map
            (\String
str ->
               Int -> String -> String
forall a. Integral a => a -> String -> String
showHex (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
showCRLF (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               String -> String -> String
showString String
str (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
showCRLF)
            (Int -> String -> [String]
forall a. Int -> [a] -> [[a]]
slice Int
chunkSize String
body) [String -> String] -> [String -> String] -> [String -> String]
forall a. [a] -> [a] -> [a]
++
         -- terminating chunk
         String -> String -> String
showString String
"0" (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
showCRLF (String -> String) -> [String -> String] -> [String -> String]
forall a. a -> [a] -> [a]
:
         -- terminating trailer
         String -> String
showCRLF (String -> String) -> [String -> String] -> [String -> String]
forall a. a -> [a] -> [a]
:
         []))
     (PortNumber -> HostAddress -> SockAddr
SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) HostAddress
addr)
     

showCRLF :: ShowS
showCRLF :: String -> String
showCRLF = String -> String -> String
showString String
"\r\n"

-- cf. Data.List.HT.sliceVertical
slice :: Int -> [a] -> [[a]]
slice :: forall a. Int -> [a] -> [[a]]
slice Int
n =
  ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n) ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> Bool) -> [[a]] -> [[a]]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[a]] -> [[a]]) -> ([a] -> [[a]]) -> [a] -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a]) -> [a] -> [[a]]
forall a. (a -> a) -> a -> [a]
iterate (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n)

{- |
This server transfers documents as one parcel, using the content-length header,
and takes an additional 
-}
initServerBind
   :: Int                               -- ^ The port number
   -> Socket.HostAddress                -- ^ The host address
   -> (Request -> IO Response)          -- ^ The functionality of the Server
   -> IO Server                         -- ^ A token for the Server
initServerBind :: Int -> HostAddress -> (Request -> IO Response) -> IO Server
initServerBind Int
port HostAddress
addr =
  (String -> ([(String, String)], String))
-> SockAddr -> (Request -> IO Response) -> IO Server
initServerMain
      (\String
body -> ([(String
"Content-Length", Int -> String
forall a. Show a => a -> String
show (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
body))], String
body)) 
      (PortNumber -> HostAddress -> SockAddr
SockAddrInet (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
port) HostAddress
addr)


initServerMain
   :: (String -> ([(String, String)], String))
   -> SockAddr
   -> (Request -> IO Response)
   -> IO Server
initServerMain :: (String -> ([(String, String)], String))
-> SockAddr -> (Request -> IO Response) -> IO Server
initServerMain String -> ([(String, String)], String)
processBody SockAddr
sockAddr Request -> IO Response
callOut = do
--        installHandler sigPIPE Ignore Nothing    
--        sock  <- listenOn (PortNumber $ fromIntegral portNo)
        ProtocolNumber
num <- String -> IO ProtocolNumber
getProtocolNumber String
"tcp"
        Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket Family
Socket.AF_INET SocketType
Socket.Stream ProtocolNumber
num
        Socket -> SocketOption -> Int -> IO Server
setSocketOption Socket
sock SocketOption
Socket.ReuseAddr Int
1
        Socket -> SockAddr -> IO Server
Socket.bind Socket
sock SockAddr
sockAddr
        Socket -> Int -> IO Server
Socket.listen Socket
sock Int
Socket.maxListenQueue

        IO ThreadId -> IO Server
forall {m :: * -> *} {a} {b}. Monad m => m a -> m b
loopIO  
           (do (Socket
acceptedSock,SockAddr
_) <- Socket -> IO (Socket, SockAddr)
Socket.accept Socket
sock
               Handle
h <- Socket -> IOMode -> IO Handle
Socket.socketToHandle Socket
acceptedSock IOMode
ReadWriteMode
               IO Server -> IO ThreadId
forkIO (IO Server -> IO ThreadId) -> IO Server -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do 
                 String
ln <- Handle -> IO String
hGetLine Handle
h
                 case String -> [String]
words String
ln of
                   [String
mode,String
uri,String
"HTTP/1.1"] ->
                       case String -> Maybe URI
parseURIReference String
uri of
                         Just URI
uri' -> Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
readHeaders Handle
h String
mode URI
uri' [] Maybe Int
forall a. Maybe a
Nothing
                         Maybe URI
_ -> do String -> IO Server
forall a. Show a => a -> IO Server
print String
uri 
                                 Handle -> IO Server
hClose Handle
h
                   [String]
_                      -> Handle -> IO Server
hClose Handle
h
                 Server -> IO Server
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           ) IO Server -> IO Server -> IO Server
forall a b. IO a -> IO b -> IO a
`finally` Socket -> IO Server
Socket.close Socket
sock
  where 
      loopIO :: m a -> m b
loopIO m a
m = m a
m m a -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a -> m b
loopIO m a
m

      readHeaders :: Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
readHeaders Handle
h String
mode URI
uri [(String, String)]
hds Maybe Int
clen = do
        String
line <- Handle -> IO String
hGetLine Handle
h
        case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
line of
          (String
"\r",String
"") -> Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
sendRequest Handle
h String
mode URI
uri [(String, String)]
hds Maybe Int
clen
          (String
name,Char
':':String
rest) ->
            case (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
Char.toLower String
name of
              String
"content-length" ->
                Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
readHeaders Handle
h String
mode URI
uri ([(String, String)]
hds [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
name,(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
Char.isSpace String
rest)]) (Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall a. Read a => String -> a
read String
rest))
              String
_ ->
                Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
readHeaders Handle
h String
mode URI
uri ([(String, String)]
hds [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String
name,(Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
Char.isSpace String
rest)]) Maybe Int
clen
          (String, String)
_ -> Handle -> IO Server
hClose Handle
h -- strange format

      message :: Int -> String
message Int
code = Int -> String
forall a. Show a => a -> String
show Int
code String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                     case Int -> [(Int, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
code [(Int, String)]
longMessages of
                       Just String
msg -> String
msg
                       Maybe String
Nothing -> String
"-"
      sendRequest :: Handle
-> String -> URI -> [(String, String)] -> Maybe Int -> IO Server
sendRequest Handle
h String
mode URI
uri [(String, String)]
hds Maybe Int
clen = do
          String
reqBody' <- case Maybe Int
clen of
            Just Int
l -> (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
l) (Handle -> IO String
hGetContents Handle
h)
            Maybe Int
Nothing -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
          Response
resp <- Request -> IO Response
callOut (Request -> IO Response) -> Request -> IO Response
forall a b. (a -> b) -> a -> b
$ Request { reqMethod :: String
reqMethod = String
mode
                                    , reqURI :: URI
reqURI    = URI
uri
                                    , reqHeaders :: [(String, String)]
reqHeaders = [(String, String)]
hds
                                    , reqBody :: String
reqBody   = String
reqBody'
                                    } 
          let ([(String, String)]
additionalHeaders, String
body) =
                String -> ([(String, String)], String)
processBody (String -> ([(String, String)], String))
-> String -> ([(String, String)], String)
forall a b. (a -> b) -> a -> b
$ Response -> String
resBody Response
resp
          Handle -> [String] -> IO Server
writeLines Handle
h ([String] -> IO Server) -> [String] -> IO Server
forall a b. (a -> b) -> a -> b
$
            (String
"HTTP/1.1 " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
message (Response -> Int
resCode Response
resp)) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            (String
"Connection: close") String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
hdr,String
val) -> String
hdr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val) ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$
                Response -> [(String, String)]
resHeaders Response
resp [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. [a] -> [a] -> [a]
++ [(String, String)]
additionalHeaders) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
            String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
            []
          Handle -> String -> IO Server
hPutStr Handle
h String
body
          Handle -> IO Server
hClose Handle
h

writeLines :: Handle -> [String] -> IO ()
writeLines :: Handle -> [String] -> IO Server
writeLines Handle
h =
  Handle -> String -> IO Server
hPutStr Handle
h (String -> IO Server)
-> ([String] -> String) -> [String] -> IO Server
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\r\n")

-- | Takes an escaped query, optionally starting with '?', and returns an unescaped index-value list.
queryToArguments :: String -> [(String,String)]
queryToArguments :: String -> [(String, String)]
queryToArguments (Char
'?':String
rest) = String -> [(String, String)]
queryToArguments String
rest
queryToArguments String
input = String -> [(String, String)]
findIx String
input
   where
     findIx :: String -> [(String, String)]
findIx = (String, String) -> [(String, String)]
findIx' ((String, String) -> [(String, String)])
-> (String -> (String, String)) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'=') 
     findIx' :: (String, String) -> [(String, String)]
findIx' (String
index,Char
'=':String
rest) = String -> String -> [(String, String)]
findVal (String -> String
unEscapeString String
index) String
rest
     findIx' (String, String)
_ = []

     findVal :: String -> String -> [(String, String)]
findVal String
index = String -> (String, String) -> [(String, String)]
findVal' String
index ((String, String) -> [(String, String)])
-> (String -> (String, String)) -> String -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'&')
     findVal' :: String -> (String, String) -> [(String, String)]
findVal' String
index (String
value,Char
'&':String
rest) = (String
index,String -> String
unEscapeString String
value) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: String -> [(String, String)]
findIx String
rest
     findVal' String
index (String
value,[])       = [(String
index,String -> String
unEscapeString String
value)]
     findVal' String
_ (String, String)
_ = []

data Request = Request 
     { Request -> String
reqMethod  :: String
     , Request -> URI
reqURI     :: URI
     , Request -> [(String, String)]
reqHeaders :: [(String,String)]
     , Request -> String
reqBody    :: String
     }
     deriving Int -> Request -> String -> String
[Request] -> String -> String
Request -> String
(Int -> Request -> String -> String)
-> (Request -> String)
-> ([Request] -> String -> String)
-> Show Request
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Request -> String -> String
showsPrec :: Int -> Request -> String -> String
$cshow :: Request -> String
show :: Request -> String
$cshowList :: [Request] -> String -> String
showList :: [Request] -> String -> String
Show

data Response = Response
    { Response -> Int
resCode    :: Int
    , Response -> [(String, String)]
resHeaders :: [(String,String)]
    , Response -> String
resBody    :: String
    }
     deriving Int -> Response -> String -> String
[Response] -> String -> String
Response -> String
(Int -> Response -> String -> String)
-> (Response -> String)
-> ([Response] -> String -> String)
-> Show Response
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> Response -> String -> String
showsPrec :: Int -> Response -> String -> String
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> String -> String
showList :: [Response] -> String -> String
Show

addCache :: Int -> (String,String)
addCache :: Int -> (String, String)
addCache Int
n = (String
"Cache-Control",String
"max-age=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)

noCache :: (String,String)
noCache :: (String, String)
noCache = (String
"Cache-Control",String
"no-cache")

-- examples include "text/html" and "text/plain"

contentType :: String -> (String,String)
contentType :: String -> (String, String)
contentType String
msg = (String
"Content-Type",String
msg)

------------------------------------------------------------------------------
longMessages :: [(Int,String)]
longMessages :: [(Int, String)]
longMessages = 
    [ (Int
200,String
"OK")
    , (Int
404,String
"Not Found")
    ]