module Network.Hakyll.SimpleServer
( simpleServer
) where
import Prelude hiding (log)
import Control.Monad (forever)
import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
import Network
import System.IO
import System.Directory (doesFileExist, doesDirectoryExist)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import System.FilePath (takeExtension)
import qualified Data.Map as M
import Data.List (intercalate)
import Text.Hakyll.Util
import Text.Hakyll.Regex
log :: Chan String -> IO ()
log logChan = forever (readChan logChan >>= hPutStrLn stderr)
data ServerConfig = ServerConfig { documentRoot :: FilePath
, portNumber :: PortNumber
, logChannel :: Chan String
}
type Server = ReaderT ServerConfig IO
data Request = Request { requestMethod :: String
, requestURI :: String
, requestVersion :: String
} deriving (Ord, Eq)
instance Show Request where
show request = requestMethod request ++ " "
++ requestURI request ++ " "
++ requestVersion request
readRequest :: Handle -> Server Request
readRequest handle = do
requestLine <- liftIO $ hGetLine handle
let [method, uri, version] = map trim $ splitRegex " " requestLine
request = Request { requestMethod = method
, requestURI = uri
, requestVersion = version
}
return request
data Response = Response { responseVersion :: String
, responseStatusCode :: Int
, responsePhrase :: String
, responseHeaders :: M.Map String String
, responseBody :: String
} deriving (Ord, Eq)
instance Show Response where
show response = responseVersion response ++ " "
++ show (responseStatusCode response) ++ " "
++ responsePhrase response
defaultResponse :: Response
defaultResponse = Response { responseVersion = "HTTP/1.1"
, responseStatusCode = 0
, responsePhrase = ""
, responseHeaders = M.empty
, responseBody = ""
}
createResponse :: Request -> Server Response
createResponse request
| requestMethod request == "GET" = createGetResponse request
| otherwise = return $ createErrorResponse 501 "Not Implemented"
createErrorResponse :: Int
-> String
-> Response
createErrorResponse statusCode phrase = defaultResponse
{ responseStatusCode = statusCode
, responsePhrase = phrase
, responseHeaders = M.singleton "Content-Type" "text/html"
, responseBody =
"<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
++ "<p>" ++ phrase ++ "</p> </body> </html>"
}
createGetResponse :: Request -> Server Response
createGetResponse request = do
config <- ask
let uri = requestURI request
log' = writeChan (logChannel config)
isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
let fileName =
documentRoot config ++ if isDirectory then uri ++ "/index.html"
else uri
create200 = do
h <- openBinaryFile fileName ReadMode
contentLength <- hFileSize h
body <- hGetContents h
let mimeHeader = getMIMEHeader fileName
headers = ("Content-Length", show contentLength) : mimeHeader
return $ defaultResponse
{ responseStatusCode = 200
, responsePhrase = "OK"
, responseHeaders = responseHeaders defaultResponse
`M.union` M.fromList headers
, responseBody = body
}
create500 e = do
log' $ "Internal Error: " ++ show e
return $ createErrorResponse 500 "Internal Server Error"
exists <- liftIO $ doesFileExist fileName
if exists
then liftIO $ catch create200 create500
else do liftIO $ log' $ "Not Found: " ++ fileName
return $ createErrorResponse 404 "Not Found"
getMIMEHeader :: FilePath -> [(String, String)]
getMIMEHeader fileName =
case result of (Just x) -> [("Content-Type", x)]
Nothing -> []
where
result = lookup (takeExtension fileName) [ (".css", "text/css")
, (".gif", "image/gif")
, (".htm", "text/html")
, (".html", "text/html")
, (".jpeg", "image/jpeg")
, (".jpg", "image/jpeg")
, (".js", "text/javascript")
, (".png", "image/png")
, (".txt", "text/plain")
, (".xml", "text/xml")
]
respond :: Handle -> Server ()
respond handle = do
request <- readRequest handle
response <- createResponse request
config <- ask
liftIO $ writeChan (logChannel config)
$ show request ++ " => " ++ show response
liftIO $ putResponse response
where
putResponse response = do hPutStr handle $ intercalate " "
[ responseVersion response
, show $ responseStatusCode response
, responsePhrase response
]
hPutStr handle "\r\n"
mapM_ putHeader
(M.toList $ responseHeaders response)
hPutStr handle "\r\n"
hPutStr handle $ responseBody response
hPutStr handle "\r\n"
hClose handle
putHeader (key, value) =
hPutStr handle $ key ++ ": " ++ value ++ "\r\n"
simpleServer :: PortNumber -> FilePath -> IO ()
simpleServer port root = do
logChan <- newChan
let config = ServerConfig { documentRoot = root
, portNumber = port
, logChannel = logChan
}
listen socket = do (handle, _, _) <- accept socket
forkIO (runReaderT (respond handle) config)
_ <- forkIO (log logChan)
writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
socket <- listenOn (PortNumber port)
forever (listen socket)