module Network.Hakyll.SimpleServer
( simpleServer
) where
import Prelude hiding (log)
import Network
import Control.Monad (forever, mapM_)
import Control.Monad.Reader (ReaderT, runReaderT, ask, liftIO)
import System.IO (Handle, hClose, hGetLine, hPutStr, hPutStrLn, stderr)
import System.Directory (doesFileExist, doesDirectoryExist)
import Control.Concurrent (forkIO)
import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
import System.FilePath (takeExtension)
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import Text.Hakyll.Util
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 :: B.ByteString
, requestURI :: B.ByteString
, requestVersion :: B.ByteString
} deriving (Ord, Eq)
instance Show Request where
show request = (B.unpack $ requestMethod request) ++ " "
++ (B.unpack $ requestURI request) ++ " "
++ (B.unpack $ requestVersion request)
readRequest :: Handle -> Server Request
readRequest handle = do
requestLine <- liftIO $ hGetLine handle
let [method, uri, version] = map trim $ split " " requestLine
return $ Request { requestMethod = B.pack method
, requestURI = B.pack uri
, requestVersion = B.pack version
}
data Response = Response { responseVersion :: B.ByteString
, responseStatusCode :: Int
, responsePhrase :: B.ByteString
, responseHeaders :: M.Map B.ByteString B.ByteString
, responseBody :: B.ByteString
} deriving (Ord, Eq)
instance Show Response where
show response = (B.unpack $ responseVersion response) ++ " "
++ (show $ responseStatusCode response) ++ " "
++ (B.unpack $ responsePhrase response)
defaultResponse :: Response
defaultResponse = Response { responseVersion = B.pack "HTTP/1.1"
, responseStatusCode = 0
, responsePhrase = B.empty
, responseHeaders = M.empty
, responseBody = B.empty
}
createResponse :: Request -> Server Response
createResponse request | requestMethod request == B.pack "GET" = createGetResponse request
| otherwise = return $ createErrorResponse 501 (B.pack "Not Implemented")
createErrorResponse :: Int
-> B.ByteString
-> Response
createErrorResponse statusCode phrase = defaultResponse
{ responseStatusCode = statusCode
, responsePhrase = phrase
, responseHeaders = M.singleton (B.pack "Content-Type") (B.pack "text/html")
, responseBody = B.pack $ "<html> <head> <title>" ++ show statusCode ++ "</title> </head>"
++ "<body> <h1>" ++ show statusCode ++ "</h1>\n"
++ "<p>" ++ (B.unpack phrase) ++ "</p> </body> </html>"
}
createGetResponse :: Request -> Server Response
createGetResponse request = do
config <- ask
let uri = B.unpack (requestURI request)
isDirectory <- liftIO $ doesDirectoryExist $ documentRoot config ++ uri
let fileName = (documentRoot config) ++ if isDirectory then uri ++ "/index.html"
else uri
create200 = do
body <- B.readFile fileName
let headers = [ (B.pack "Content-Length", B.pack $ show $ B.length body)
] ++ getMIMEHeader fileName
return $ defaultResponse { responseStatusCode = 200
, responsePhrase = B.pack "OK"
, responseHeaders = (responseHeaders defaultResponse)
`M.union` M.fromList headers
, responseBody = body
}
create500 e = do writeChan (logChannel config) $ "Internal Error: " ++ show e
return $ createErrorResponse 500 (B.pack "Internal Server Error")
exists <- liftIO $ doesFileExist fileName
if exists then do response <- liftIO $ catch create200 create500
return response
else do liftIO $ writeChan (logChannel config) $ "Not Found: " ++ fileName
return $ createErrorResponse 404 (B.pack "Not Found")
getMIMEHeader :: FilePath -> [(B.ByteString, B.ByteString)]
getMIMEHeader fileName = case result of (Just x) -> [(B.pack "Content-Type", B.pack 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 B.hPutStr handle $ B.intercalate (B.pack " ")
[ responseVersion response
, B.pack $ show $ responseStatusCode response
, responsePhrase response
]
hPutStr handle "\r\n"
mapM_ putHeader (M.toList $ responseHeaders response)
hPutStr handle "\r\n"
B.hPutStr handle $ responseBody response
hPutStr handle "\r\n"
hClose handle
putHeader (key, value) = B.hPutStr handle $ key `B.append` B.pack ": "
`B.append` value `B.append` B.pack "\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)
return ()
forkIO (log logChan)
writeChan logChan $ "Starting hakyll server on port " ++ show port ++ "..."
socket <- listenOn (PortNumber port)
forever (listen socket)
where