Fixed warningsHEADmaster

8 files changed, 51 insertions, 36 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 433ad8d..7ca801a 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -5,7 +5,6 @@ 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
@@ -13,26 +12,26 @@ import Network.Socket.ByteString (recv, sendAll)
 
 import Web.Utils
 import Web.Response
-import Web.Router
+import qualified Web.Router
 import Routes
 
-import Settings (host, port)
+import qualified Settings
 
 main :: IO ()
 main = do
-  let hostStr = case host of
+  let hostStr = case Settings.host of
                   Just smt -> smt
                   Nothing  -> "0.0.0.0"
 
-  putStrLn $ "Server launched on " ++ hostStr ++ ":" ++ port
-  runTCPServer host port talk
+  putStrLn $ "Server launched on " ++ hostStr ++ ":" ++ Settings.port
+  runTCPServer Settings.host Settings.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
+        response <- Web.Router.resolve routesTable $ request
         sendAll s $ encodeUtf8 (formResponse response)
 
 runTCPServer :: Maybe HostName -> ServiceName -> (Socket -> IO a) -> IO a
diff --git a/app/Routes.hs b/app/Routes.hs
index 3dbb3aa..09d4a64 100644
--- a/app/Routes.hs
+++ b/app/Routes.hs
@@ -2,13 +2,11 @@ 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]
 routesTable = [ Route indexGet (T.pack "/") GET
-              , Route helloGet (T.pack "/hello") GET ]
\ No newline at end of file
+              , Route helloGet (T.pack "/hello") GET ]
diff --git a/app/Settings.hs b/app/Settings.hs
index 0d55606..6c0f129 100644
--- a/app/Settings.hs
+++ b/app/Settings.hs
@@ -1,4 +1,7 @@
 module Settings where
 
+host :: Maybe String
 host = Nothing
+
+port :: String
 port = "3000"
diff --git a/app/Views.hs b/app/Views.hs
index 54cd844..2e0482f 100644
--- a/app/Views.hs
+++ b/app/Views.hs
@@ -8,10 +8,10 @@ import Web.Request
 import Web.Response
 
 indexGet :: Request -> IO Response
-indexGet req = renderTemplate "index.html"
+indexGet _ = renderTemplate "index.html"
 
 helloGet :: Request -> IO Response
-helloGet req = renderTemplate "hello.html"
+helloGet _ = renderTemplate "hello.html"
 
 renderTemplate :: String -> IO Response
 renderTemplate name = do
diff --git a/app/Web/Request.hs b/app/Web/Request.hs
index 71dc421..96144b8 100644
--- a/app/Web/Request.hs
+++ b/app/Web/Request.hs
@@ -8,8 +8,11 @@ import Web.Http
 data Request = Request [QueryPair] Text Method
   deriving Show
 
+getQuery :: Request -> [QueryPair]
 getQuery (Request query _ _) = query
 
+getUrl :: Request -> Text
 getUrl (Request _ url _) = url
 
-getMethod (Request _ _ method) = method
\ No newline at end of file
+getMethod :: Request -> Method
+getMethod (Request _ _ method) = method
diff --git a/app/Web/Response.hs b/app/Web/Response.hs
index 3c393ad..11ab5f2 100644
--- a/app/Web/Response.hs
+++ b/app/Web/Response.hs
@@ -10,21 +10,27 @@ data Response
   | TextResponse Int Text Text -- Код возврата, Content-Type, содержимое HTML
   deriving Show
 
+notFoundResponse :: Response
 notFoundResponse = HtmlResponse 404 (T.pack "<strong>404 Not Found</strong>")
 
+getStatusCode :: Response -> Int
 getStatusCode (HtmlResponse code _) = code
 getStatusCode (TextResponse code _ _) = code
 
+getContentType :: Response -> Text
 getContentType (HtmlResponse _ _) = (T.pack "text/html")
 getContentType (TextResponse _ contentType _) = contentType
 
+getContent :: Response -> Text
 getContent (HtmlResponse _ content) = content
 getContent (TextResponse _ _ content) = content
 
 formResponse :: Response -> Text
-formResponse (HtmlResponse code html) = 
+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]
+-- TODO: Добавить обработчик
+formResponse _ = undefined
diff --git a/app/Web/Utils.hs b/app/Web/Utils.hs
index 97bc512..e77754f 100644
--- a/app/Web/Utils.hs
+++ b/app/Web/Utils.hs
@@ -1,12 +1,11 @@
 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 Data.Maybe (catMaybes)
 
 import Web.Http
 import Web.Request
@@ -25,18 +24,17 @@ parseQs url =
 
     parsePair :: Text -> Maybe QueryPair
     parsePair s
-      | T.any ((==) '=') s = Just (QueryPair a b)
+      | T.any ((==) '=') s =
+          case T.splitOn (T.pack "=") s of
+            []            -> Nothing
+            [_]           -> Nothing
+            key : val : _ -> Just (QueryPair key val)
       | otherwise = Nothing
-      where a : b : _ = T.splitOn (T.pack "=") s
-    
-    get (Just p : rest) = p : get rest
-    get (Nothing : rest) = get rest
-    get [] = []
 
-    pairs = 
+    pairs =
       if T.null rest
       then []
-      else get $ map parsePair $ T.splitOn (T.pack "&") $ T.tail rest
+      else catMaybes $ map parsePair $ T.splitOn (T.pack "&") $ T.tail rest
 
   in (path, pairs)
 
@@ -51,12 +49,16 @@ parseMethod s
   | s == (T.pack "PUT")  = PUT
   | otherwise            = GET
 
+-- TODO: добавить нормальную обработку ошибочных ситуаций
 parseFirstLine :: Text -> (Method, Text)
-parseFirstLine l = (parseMethod methodT, url)
-  where [methodT, url, _] = T.words l
+parseFirstLine l =
+  case T.words l of
+    []                -> undefined
+    [_]               -> undefined
+    methodT : url : _ -> (parseMethod methodT, url)
 
 parseHeader :: Text -> Header
-parseHeader line = 
+parseHeader line =
   Header (T.takeWhile p line)
          (T.strip $ T.tail $ T.dropWhile p line)
     where p = (\c -> c /= ':')
@@ -64,28 +66,32 @@ parseHeader line =
 parseHeaders :: [Text] -> [Header]
 parseHeaders = map parseHeader
 
--- parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text])
 parseHttp :: Text -> (Request, [Header], [Text])
-parseHttp text = 
+parseHttp text =
   let
-    lines = T.splitOn (T.pack "\r\n") text
+    textLines = T.splitOn (T.pack "\r\n") text
 
     getFirstLine (l : rest) = (l, rest)
+    -- TODO: добавить нормальную обработку ошибочных ситуаций
+    getFirstLine [] = undefined
 
     getHeaders (l : rest) acc
       | T.null l  = (rev acc, rest)
       | otherwise = getHeaders rest (l : acc)
-    
-    (fl, rest1) = getFirstLine lines
+    -- TODO: добавить нормальную обработку ошибочных ситуаций
+    getHeaders [] _ = undefined
+
+    (fl, rest1) = getFirstLine textLines
     (headers, rest2) = getHeaders rest1 []
 
     (method, url) = parseFirstLine fl
     (path, query) = parseQs url
-  in 
+  in
     ((Request query path method), parseHeaders headers, rest2)
 
 -- HTTP Status Codes
-statusCodes = 
+statusCodes :: [(Int, String)]
+statusCodes =
   [ (100, "Continue"),
     (101, "Switching Protocols"),
     (102, "Processing"),
diff --git a/haskell-web.cabal b/haskell-web.cabal
index 6570c2f..fcc82fa 100644
--- a/haskell-web.cabal
+++ b/haskell-web.cabal
@@ -1,7 +1,7 @@
 cabal-version:      3.0
 
 name:               haskell-web
-version:            0.1.0.1
+version:            0.1.0.2
 license:            BSD-2-Clause
 license-file:       LICENSE
 author:             Andrew Guschin