From a0e8e5a91d15ed8c79f4a1b5914d3a6242c0cbd3 Mon Sep 17 00:00:00 2001 From: Andrew Guschin Date: Sun, 5 Mar 2023 13:45:37 +0400 Subject: Migrated project to cabal --- .gitignore | 4 +- LICENSE | 26 +++++++++ Main.hs | 58 -------------------- Routes.hs | 14 ----- Settings.hs | 4 -- Setup.hs | 2 - Views.hs | 25 --------- Web/Http.hs | 12 ----- Web/Request.hs | 15 ------ Web/Response.hs | 30 ----------- Web/Router.hs | 17 ------ Web/Utils.hs | 153 ---------------------------------------------------- app/Main.hs | 58 ++++++++++++++++++++ app/Routes.hs | 14 +++++ app/Settings.hs | 4 ++ app/Views.hs | 25 +++++++++ app/Web/Http.hs | 12 +++++ app/Web/Request.hs | 15 ++++++ app/Web/Response.hs | 30 +++++++++++ app/Web/Router.hs | 17 ++++++ app/Web/Utils.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++++ haskell-web.cabal | 60 +++++++++++---------- net/Client.hs | 30 ----------- net/Server.hs | 65 ---------------------- net/client.hs | 30 ----------- net/server.hs | 42 --------------- stack.yaml | 67 ----------------------- 27 files changed, 387 insertions(+), 595 deletions(-) create mode 100644 LICENSE delete mode 100644 Main.hs delete mode 100644 Routes.hs delete mode 100644 Settings.hs delete mode 100644 Setup.hs delete mode 100644 Views.hs delete mode 100644 Web/Http.hs delete mode 100644 Web/Request.hs delete mode 100644 Web/Response.hs delete mode 100644 Web/Router.hs delete mode 100644 Web/Utils.hs create mode 100644 app/Main.hs create mode 100644 app/Routes.hs create mode 100644 app/Settings.hs create mode 100644 app/Views.hs create mode 100644 app/Web/Http.hs create mode 100644 app/Web/Request.hs create mode 100644 app/Web/Response.hs create mode 100644 app/Web/Router.hs create mode 100644 app/Web/Utils.hs delete mode 100644 net/Client.hs delete mode 100644 net/Server.hs delete mode 100644 net/client.hs delete mode 100644 net/server.hs delete mode 100644 stack.yaml diff --git a/.gitignore b/.gitignore index 558187b..5c6e4c0 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,2 @@ -.stack-work +.* dist-newstyle -*.save* -*.lock \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..027b050 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2023, Andrew Guschin +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 433ad8d..0000000 --- a/Main.hs +++ /dev/null @@ -1,58 +0,0 @@ -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/Routes.hs b/Routes.hs deleted file mode 100644 index 3dbb3aa..0000000 --- a/Routes.hs +++ /dev/null @@ -1,14 +0,0 @@ -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/Settings.hs b/Settings.hs deleted file mode 100644 index 0d55606..0000000 --- a/Settings.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Settings where - -host = Nothing -port = "3000" diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Views.hs b/Views.hs deleted file mode 100644 index 54cd844..0000000 --- a/Views.hs +++ /dev/null @@ -1,25 +0,0 @@ -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/Web/Http.hs b/Web/Http.hs deleted file mode 100644 index 92cb043..0000000 --- a/Web/Http.hs +++ /dev/null @@ -1,12 +0,0 @@ -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/Web/Request.hs b/Web/Request.hs deleted file mode 100644 index 71dc421..0000000 --- a/Web/Request.hs +++ /dev/null @@ -1,15 +0,0 @@ -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/Web/Response.hs b/Web/Response.hs deleted file mode 100644 index 3c393ad..0000000 --- a/Web/Response.hs +++ /dev/null @@ -1,30 +0,0 @@ -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 "404 Not Found") - -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/Web/Router.hs b/Web/Router.hs deleted file mode 100644 index 234f30a..0000000 --- a/Web/Router.hs +++ /dev/null @@ -1,17 +0,0 @@ -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/Web/Utils.hs b/Web/Utils.hs deleted file mode 100644 index 97bc512..0000000 --- a/Web/Utils.hs +++ /dev/null @@ -1,153 +0,0 @@ -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" 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 "404 Not Found") + +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" diff --git a/haskell-web.cabal b/haskell-web.cabal index 9fd655e..6570c2f 100644 --- a/haskell-web.cabal +++ b/haskell-web.cabal @@ -1,31 +1,35 @@ -cabal-version: >=1.10 --- Initial package description 'haskell-web.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ +cabal-version: 3.0 -name: haskell-web -version: 0.1.0.0 -author: Andrew -maintainer: saintruler@gmail.com -build-type: Simple +name: haskell-web +version: 0.1.0.1 +license: BSD-2-Clause +license-file: LICENSE +author: Andrew Guschin +maintainer: guschin.drew@gmail.com +build-type: Simple + +common warnings + ghc-options: -Wall executable haskell-web - main-is: Main.hs - other-modules: - Web.Http - , Web.Request - , Web.Response - , Web.Router - , Web.Utils - , Views - , Routes - , Settings - -- other-extensions: - build-depends: - base >=4.14 && <4.15 - , text - , http-types - , bytestring - , network - -- hs-source-dirs: - default-language: Haskell2010 + -- Import common warning flags. + import: warnings + hs-source-dirs: app + default-language: Haskell2010 + + main-is: Main.hs + other-modules: + Web.Http + , Web.Request + , Web.Response + , Web.Router + , Web.Utils + , Views + , Routes + , Settings + build-depends: + base ^>=4.17.0.0 + , text + , http-types + , bytestring + , network diff --git a/net/Client.hs b/net/Client.hs deleted file mode 100644 index 863df6e..0000000 --- a/net/Client.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- Echo client program -module Main (main) where - -import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as C -import Network.Socket -import Network.Socket.ByteString (recv, sendAll) - -main :: IO () -main = runTCPClient "127.0.0.1" "3000" $ \s -> do - sendAll s "Hello, world!" - msg <- recv s 1024 - putStr "Received: " - C.putStrLn msg - --- from the "network-run" package. -runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a -runTCPClient host port client = withSocketsDo $ do - addr <- resolve - E.bracket (open addr) close client - where - resolve = do - let hints = defaultHints { addrSocketType = Stream } - head <$> getAddrInfo (Just hints) (Just host) (Just port) - open addr = do - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - connect sock $ addrAddress addr - return sock - diff --git a/net/Server.hs b/net/Server.hs deleted file mode 100644 index 0e53330..0000000 --- a/net/Server.hs +++ /dev/null @@ -1,65 +0,0 @@ --- Echo server program -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 (encodeUtf8) - -import Network.Socket -import Network.Socket.ByteString (recv, sendAll) - -join :: String -> [String] -> String -join delim [] = "" -join delim (s : []) = s -join delim (s : rest) = - s ++ delim ++ join delim rest - -packStr :: String -> S.ByteString -packStr = encodeUtf8 . T.pack - -(+++) = S.append - -response = join "\n" - [ "HTTP/1.1 200 OK" - , "Content-Type: text/html; charset=utf-8" - , "Connection: keep-alive" - , "" - , "PRIVET" - ] - -main :: IO () -main = runTCPServer Nothing "3000" talk - where - talk s = do - msg <- recv s 1024 - print msg - unless (S.null msg) $ do - sendAll s (packStr response) - talk s - --- from the "network-run" package. -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/net/client.hs b/net/client.hs deleted file mode 100644 index 863df6e..0000000 --- a/net/client.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- Echo client program -module Main (main) where - -import qualified Control.Exception as E -import qualified Data.ByteString.Char8 as C -import Network.Socket -import Network.Socket.ByteString (recv, sendAll) - -main :: IO () -main = runTCPClient "127.0.0.1" "3000" $ \s -> do - sendAll s "Hello, world!" - msg <- recv s 1024 - putStr "Received: " - C.putStrLn msg - --- from the "network-run" package. -runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a -runTCPClient host port client = withSocketsDo $ do - addr <- resolve - E.bracket (open addr) close client - where - resolve = do - let hints = defaultHints { addrSocketType = Stream } - head <$> getAddrInfo (Just hints) (Just host) (Just port) - open addr = do - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - connect sock $ addrAddress addr - return sock - diff --git a/net/server.hs b/net/server.hs deleted file mode 100644 index a9bec82..0000000 --- a/net/server.hs +++ /dev/null @@ -1,42 +0,0 @@ --- Echo server program -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 Network.Socket -import Network.Socket.ByteString (recv, sendAll) - -main :: IO () -main = runTCPServer Nothing "3000" talk - where - talk s = do - msg <- recv s 1024 - unless (S.null msg) $ do - sendAll s msg - talk s - --- from the "network-run" package. -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/stack.yaml b/stack.yaml deleted file mode 100644 index 43c8738..0000000 --- a/stack.yaml +++ /dev/null @@ -1,67 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2020/11/23.yaml - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.5" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor -- cgit v1.2.3