From 446602fe336ad1c2a23e3d50d7cd1d1356fcc9de Mon Sep 17 00:00:00 2001 From: Andrew Guschin Date: Thu, 26 Nov 2020 13:55:55 +0400 Subject: Initial commit --- .gitignore | 2 ++ CHANGELOG.md | 5 +++++ Main.hs | 25 +++++++++++++++++++++++++ Request.hs | 9 +++++++++ Response.hs | 15 +++++++++++++++ Router.hs | 21 +++++++++++++++++++++ Setup.hs | 2 ++ hask.cabal | 25 +++++++++++++++++++++++++ hie.yaml | 2 ++ net/client.hs | 30 ++++++++++++++++++++++++++++++ net/server.hs | 42 ++++++++++++++++++++++++++++++++++++++++++ templates/hello.html | 9 +++++++++ templates/index.html | 9 +++++++++ 13 files changed, 196 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 Main.hs create mode 100644 Request.hs create mode 100644 Response.hs create mode 100644 Router.hs create mode 100644 Setup.hs create mode 100644 hask.cabal create mode 100644 hie.yaml create mode 100644 net/client.hs create mode 100644 net/server.hs create mode 100644 templates/hello.html create mode 100644 templates/index.html diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..4123af9 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle +*.save0 \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..d41f76e --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for hask + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..1bc06d5 --- /dev/null +++ b/Main.hs @@ -0,0 +1,25 @@ +module Main where + +import System.IO +import Response +import Router + +renderTemplate name = do + template <- readTemplate name + return $ HtmlResponse 200 template + +readTemplate name = do + handle <- openFile ("templates/" ++ name) ReadMode + hGetContents handle + +route url method + | url == "/" = renderTemplate "index.html" + | url == "/hello" = renderTemplate "hello.html" + +table = [ + Route +] + +main = do + response <- route "/hello" "GET" + print $ getContent response \ No newline at end of file diff --git a/Request.hs b/Request.hs new file mode 100644 index 0000000..a0c18d7 --- /dev/null +++ b/Request.hs @@ -0,0 +1,9 @@ +module Request where + +data Request = Request String String String + +getQuery (Request query _ _) = query + +getUrl (Request _ url _) = url + +getMethod (Request _ _ method) = method \ No newline at end of file diff --git a/Response.hs b/Response.hs new file mode 100644 index 0000000..f33777d --- /dev/null +++ b/Response.hs @@ -0,0 +1,15 @@ +module Response where + +data Response = + HtmlResponse Int String -- Код возврата, содержимое HTML + | TextResponse Int String String -- Код возврата, Content-Type, содержимое HTML + + +getStatusCode (HtmlResponse code _) = code +getStatusCode (TextResponse code _ _) = code + +getContentType (HtmlResponse _ _) = "text/html" +getContentType (TextResponse _ contentType _) = contentType + +getContent (HtmlResponse _ content) = content +getContent (TextResponse _ _ content) = content \ No newline at end of file diff --git a/Router.hs b/Router.hs new file mode 100644 index 0000000..4798ec1 --- /dev/null +++ b/Router.hs @@ -0,0 +1,21 @@ +module Router where + +import Control.Exception +import Response +import Request + +data Route = Route (Request -> IO Response) String String + +data RouterError = RouteNotFound + deriving Show + +instance Exception RouterError + +getResponse [] _ = throw RouteNotFound +getResponse (Route callback routeUrl _ : routerTable) req @ (Request _ url _) = + if url == routeUrl then + callback req + else getResponse routerTable req + +router table req = + diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hask.cabal b/hask.cabal new file mode 100644 index 0000000..abc15ba --- /dev/null +++ b/hask.cabal @@ -0,0 +1,25 @@ +cabal-version: >=1.10 +-- Initial package description 'hask.cabal' generated by 'cabal init'. For +-- further documentation, see http://haskell.org/cabal/users-guide/ + +name: hask +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +-- license: +license-file: LICENSE +author: Andrew Guschin +maintainer: saintruler@gmail.com +-- copyright: +-- category: +build-type: Simple +extra-source-files: CHANGELOG.md + +executable hask + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: base >=4.14 && <4.15 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000..142e69f --- /dev/null +++ b/hie.yaml @@ -0,0 +1,2 @@ +cradle: + stack: \ No newline at end of file diff --git a/net/client.hs b/net/client.hs new file mode 100644 index 0000000..863df6e --- /dev/null +++ b/net/client.hs @@ -0,0 +1,30 @@ +{-# 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 new file mode 100644 index 0000000..a9bec82 --- /dev/null +++ b/net/server.hs @@ -0,0 +1,42 @@ +-- 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/templates/hello.html b/templates/hello.html new file mode 100644 index 0000000..cb0681d --- /dev/null +++ b/templates/hello.html @@ -0,0 +1,9 @@ + + + + Document + + + Hello! + + \ No newline at end of file diff --git a/templates/index.html b/templates/index.html new file mode 100644 index 0000000..2f82895 --- /dev/null +++ b/templates/index.html @@ -0,0 +1,9 @@ + + + + Document + + + This is index page + + \ No newline at end of file -- cgit v1.2.3