Migrated project to cabal

9 files changed, 328 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..433ad8d
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,58 @@
+module Main (main) where
+
+import Control.Concurrent (forkFinally)
+import qualified Control.Exception as E
+import Control.Monad (unless, forever, void)
+
+import qualified Data.ByteString as S
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+
+import Network.Socket
+import Network.Socket.ByteString (recv, sendAll)
+
+import Web.Utils
+import Web.Response
+import Web.Router
+import Routes
+
+import Settings (host, port)
+
+main :: IO ()
+main = do
+  let hostStr = case host of
+                  Just smt -> smt
+                  Nothing  -> "0.0.0.0"
+
+  putStrLn $ "Server launched on " ++ hostStr ++ ":" ++ port
+  runTCPServer host port talk
+  where
+    talk s = do
+      msg <- recv s 1024
+      putStrLn "Got request"
+      unless (S.null msg) $ do
+        let (request, _, _) = parseHttp $ decodeUtf8 msg
+        response <- resolve routesTable $ request
+        sendAll s $ encodeUtf8 (formResponse response)
+
+runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
+runTCPServer mhost port server = withSocketsDo $ do
+    addr <- resolve
+    E.bracket (open addr) close loop
+  where
+    resolve = do
+        let hints = defaultHints {
+                addrFlags = [AI_PASSIVE]
+              , addrSocketType = Stream
+              }
+        head <$> getAddrInfo (Just hints) mhost (Just port)
+    open addr = do
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        setSocketOption sock ReuseAddr 1
+        withFdSocket sock $ setCloseOnExecIfNeeded
+        bind sock $ addrAddress addr
+        listen sock 1024
+        return sock
+    loop sock = forever $ do
+        (conn, _peer) <- accept sock
+        void $ forkFinally (server conn) (const $ gracefulClose conn 5000)
diff --git a/app/Routes.hs b/app/Routes.hs
new file mode 100644
index 0000000..3dbb3aa
--- /dev/null
+++ b/app/Routes.hs
@@ -0,0 +1,14 @@
+module Routes where
+
+import qualified Data.Text as T
+
+import Web.Response
+import Web.Request
+import Web.Router
+import Web.Utils
+import Web.Http
+
+import Views
+
+routesTable = [ Route indexGet (T.pack "/") GET
+              , Route helloGet (T.pack "/hello") GET ]
\ No newline at end of file
diff --git a/app/Settings.hs b/app/Settings.hs
new file mode 100644
index 0000000..0d55606
--- /dev/null
+++ b/app/Settings.hs
@@ -0,0 +1,4 @@
+module Settings where
+
+host = Nothing
+port = "3000"
diff --git a/app/Views.hs b/app/Views.hs
new file mode 100644
index 0000000..54cd844
--- /dev/null
+++ b/app/Views.hs
@@ -0,0 +1,25 @@
+module Views where
+
+import System.IO
+import qualified Data.Text as T
+import Data.Text (Text)
+
+import Web.Request
+import Web.Response
+
+indexGet :: Request -> IO Response
+indexGet req = renderTemplate "index.html"
+
+helloGet :: Request -> IO Response
+helloGet req = renderTemplate "hello.html"
+
+renderTemplate :: String -> IO Response
+renderTemplate name = do
+  template <- readTemplate name
+  return $ HtmlResponse 200 template
+
+readTemplate :: String -> IO Text
+readTemplate name = do
+  handle <- openFile ("templates/" ++ name) ReadMode
+  contents <- hGetContents handle
+  return $ T.pack contents
diff --git a/app/Web/Http.hs b/app/Web/Http.hs
new file mode 100644
index 0000000..92cb043
--- /dev/null
+++ b/app/Web/Http.hs
@@ -0,0 +1,12 @@
+module Web.Http where
+
+import Data.Text (Text)
+
+data Header = Header Text Text
+  deriving Show
+
+data Method = GET | PUT | POST
+  deriving (Show, Eq)
+
+data QueryPair = QueryPair Text Text
+  deriving Show
diff --git a/app/Web/Request.hs b/app/Web/Request.hs
new file mode 100644
index 0000000..71dc421
--- /dev/null
+++ b/app/Web/Request.hs
@@ -0,0 +1,15 @@
+module Web.Request where
+
+import Data.Text (Text)
+
+import Web.Http
+
+-- Request query url method
+data Request = Request [QueryPair] Text Method
+  deriving Show
+
+getQuery (Request query _ _) = query
+
+getUrl (Request _ url _) = url
+
+getMethod (Request _ _ method) = method
\ No newline at end of file
diff --git a/app/Web/Response.hs b/app/Web/Response.hs
new file mode 100644
index 0000000..3c393ad
--- /dev/null
+++ b/app/Web/Response.hs
@@ -0,0 +1,30 @@
+module Web.Response where
+
+import qualified Data.Text as T
+import Data.Text (Text)
+
+import Web.Utils
+
+data Response
+  = HtmlResponse Int Text -- Код возврата, содержимое HTML
+  | TextResponse Int Text Text -- Код возврата, Content-Type, содержимое HTML
+  deriving Show
+
+notFoundResponse = HtmlResponse 404 (T.pack "<strong>404 Not Found</strong>")
+
+getStatusCode (HtmlResponse code _) = code
+getStatusCode (TextResponse code _ _) = code
+
+getContentType (HtmlResponse _ _) = (T.pack "text/html")
+getContentType (TextResponse _ contentType _) = contentType
+
+getContent (HtmlResponse _ content) = content
+getContent (TextResponse _ _ content) = content
+
+formResponse :: Response -> Text
+formResponse (HtmlResponse code html) = 
+  T.strip $ T.unlines
+  $ map T.pack [ "HTTP/1.1 " ++ getStatus code
+               , "Content-Type: text/html; charset=utf-8"
+               , "Connection: close"
+               , "" ] ++ [html]
diff --git a/app/Web/Router.hs b/app/Web/Router.hs
new file mode 100644
index 0000000..5e014d9
--- /dev/null
+++ b/app/Web/Router.hs
@@ -0,0 +1,17 @@
+module Web.Router where
+
+import Data.Text (Text)
+
+import Web.Response
+import Web.Request
+import Web.Http
+
+-- Route callback url method
+data Route = Route (Request -> IO Response) Text Method
+
+resolve :: [Route] -> Request -> IO Response
+resolve [] _ = return notFoundResponse
+resolve (Route callback routeUrl _ : routerTable) req@(Request _ url _) =
+  if url == routeUrl then
+    callback req
+  else resolve routerTable req
diff --git a/app/Web/Utils.hs b/app/Web/Utils.hs
new file mode 100644
index 0000000..97bc512
--- /dev/null
+++ b/app/Web/Utils.hs
@@ -0,0 +1,153 @@
+module Web.Utils (parseQs, parseHttp, getStatus) where
+
+import Network.HTTP.Types.URI as URI
+import qualified Data.ByteString as S
+import Data.ByteString (ByteString)
+
+import qualified Data.Text as T
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Text (Text)
+
+import Web.Http
+import Web.Request
+
+-- Query string parser
+
+decodeUrl :: Text -> Text
+decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
+
+parseQs :: Text -> (Text, [QueryPair])
+parseQs url =
+  let
+    decoded = decodeUrl url
+    path = T.takeWhile (\c -> c /= '?') decoded
+    rest = T.dropWhile (\c -> c /= '?') decoded
+
+    parsePair :: Text -> Maybe QueryPair
+    parsePair s
+      | T.any ((==) '=') s = Just (QueryPair a b)
+      | otherwise = Nothing
+      where a : b : _ = T.splitOn (T.pack "=") s
+    
+    get (Just p : rest) = p : get rest
+    get (Nothing : rest) = get rest
+    get [] = []
+
+    pairs = 
+      if T.null rest
+      then []
+      else get $ map parsePair $ T.splitOn (T.pack "&") $ T.tail rest
+
+  in (path, pairs)
+
+-- HTTP Parser
+
+rev :: [a] -> [a]
+rev = foldl (flip (:)) []
+
+parseMethod :: Text -> Method
+parseMethod s
+  | s == (T.pack "POST") = POST
+  | s == (T.pack "PUT")  = PUT
+  | otherwise            = GET
+
+parseFirstLine :: Text -> (Method, Text)
+parseFirstLine l = (parseMethod methodT, url)
+  where [methodT, url, _] = T.words l
+
+parseHeader :: Text -> Header
+parseHeader line = 
+  Header (T.takeWhile p line)
+         (T.strip $ T.tail $ T.dropWhile p line)
+    where p = (\c -> c /= ':')
+
+parseHeaders :: [Text] -> [Header]
+parseHeaders = map parseHeader
+
+-- parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text])
+parseHttp :: Text -> (Request, [Header], [Text])
+parseHttp text = 
+  let
+    lines = T.splitOn (T.pack "\r\n") text
+
+    getFirstLine (l : rest) = (l, rest)
+
+    getHeaders (l : rest) acc
+      | T.null l  = (rev acc, rest)
+      | otherwise = getHeaders rest (l : acc)
+    
+    (fl, rest1) = getFirstLine lines
+    (headers, rest2) = getHeaders rest1 []
+
+    (method, url) = parseFirstLine fl
+    (path, query) = parseQs url
+  in 
+    ((Request query path method), parseHeaders headers, rest2)
+
+-- HTTP Status Codes
+statusCodes = 
+  [ (100, "Continue"),
+    (101, "Switching Protocols"),
+    (102, "Processing"),
+    (200, "OK"),
+    (201, "Created"),
+    (202, "Accepted"),
+    (203, "Non Authoritative Information"),
+    (204, "No Content"),
+    (205, "Reset Content"),
+    (206, "Partial Content"),
+    (207, "Multi Status"),
+    (226, "IM Used"),
+    (300, "Multiple Choices"),
+    (301, "Moved Permanently"),
+    (302, "Found"),
+    (303, "See Other"),
+    (304, "Not Modified"),
+    (305, "Use Proxy"),
+    (307, "Temporary Redirect"),
+    (308, "Permanent Redirect"),
+    (400, "Bad Request"),
+    (401, "Unauthorized"),
+    (402, "Payment Required"),
+    (403, "Forbidden"),
+    (404, "Not Found"),
+    (405, "Method Not Allowed"),
+    (406, "Not Acceptable"),
+    (407, "Proxy Authentication Required"),
+    (408, "Request Timeout"),
+    (409, "Conflict"),
+    (410, "Gone"),
+    (411, "Length Required"),
+    (412, "Precondition Failed"),
+    (413, "Request Entity Too Large"),
+    (414, "Request URI Too Long"),
+    (415, "Unsupported Media Type"),
+    (416, "Requested Range Not Satisfiable"),
+    (417, "Expectation Failed"),
+    (418, "I'm a teapot"),
+    (421, "Misdirected Request"),
+    (422, "Unprocessable Entity"),
+    (423, "Locked"),
+    (424, "Failed Dependency"),
+    (426, "Upgrade Required"),
+    (428, "Precondition Required"),
+    (429, "Too Many Requests"),
+    (431, "Request Header Fields Too Large"),
+    (449, "Retry With"),
+    (451, "Unavailable For Legal Reasons"),
+    (500, "Internal Server Error"),
+    (501, "Not Implemented"),
+    (502, "Bad Gateway"),
+    (503, "Service Unavailable"),
+    (504, "Gateway Timeout"),
+    (505, "HTTP Version Not Supported"),
+    (507, "Insufficient Storage"),
+    (510, "Not Extended") ]
+
+getStatus :: Int -> String
+getStatus code = findStatus statusCodes
+  where
+    findStatus ((codeCheck, stat) : rest)
+      | codeCheck == code = show code ++ " " ++ stat
+      | otherwise         = findStatus rest
+    findStatus [] = "500 Internal Server Error"