getting my feet wet a bit

This commit is contained in:
nek0 2019-09-08 02:37:50 +02:00
parent 0af7d52ba2
commit 7de4d9d0c2
7 changed files with 131 additions and 3 deletions

View file

@ -18,9 +18,22 @@ extra-source-files: CHANGELOG.md
executable matebeamter
main-is: Main.hs
-- other-modules:
other-modules: API
, Types
, Types.Page
, View
, View.Auth
-- other-extensions:
build-depends: base ^>=4.12.0.0
mateamt
, mateamt
, servant
, servant-server
, servant-client
, servant-blaze
, servant-rawm
, blaze-html
, text
, warp
, wai-logger
hs-source-dirs: src
default-language: Haskell2010

23
src/API.hs Normal file
View file

@ -0,0 +1,23 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module API where
import Servant.API
import Servant.RawM
import Servant.HTML.Blaze
-- internal imports
import Types
import View
type UserAPI =
"auth" :> Get '[HTML] AuthPage

View file

@ -1,4 +1,28 @@
module Main where
import Servant
import Servant.Server
import Network.Wai.Handler.Warp
import Network.Wai.Logger
-- internal imports
import API
import Types
import View
main :: IO ()
main = putStrLn "Hello, Haskell!"
main = do
withStdoutLogger $ \ilog -> do
let settings = setPort 3000 $ setLogger ilog defaultSettings
runSettings settings app
app :: Application
app = serve userApi userServer
userApi :: Proxy UserAPI
userApi = Proxy
userServer :: Server UserAPI
userServer = return authPage

5
src/Types.hs Normal file
View file

@ -0,0 +1,5 @@
module Types
( module T
) where
import Types.Page as T

46
src/Types/Page.hs Normal file
View file

@ -0,0 +1,46 @@
{-# LANGUAGE OverloadedStrings #-}
module Types.Page where
import qualified Data.Text as T
import qualified Text.Blaze.Html5 as H
data Page markup attr = Page
{ pageTitle :: attr -- ^ Page title
, pageFavicon :: markup -- ^ Favicon tags
, pageMetaVars :: markup -- ^ @\<meta\>@ tags
-- , initScripts :: markup -- ^ JavaScript to include at the top of the page
-- , beforeStylesScripts :: markup -- ^ JavaScript to include before @\<style\>@ tags
, pageStyles :: markup -- ^ Styles
-- , afterStylesScripts :: markup -- ^ JavaScript to include after @\<style\>@ tags - ie: <http://modernizr.com Modernizr>
-- , bodyScripts :: markup -- ^ JavaScript to include at the base of @\<body\>@
-- , bodyStyles :: attrSet -- ^ Additional styles to assign to @\<body\>@
} deriving (Show, Eq, Ord)
instance (Semigroup m, Semigroup a) => Semigroup (Page m a)
where
(Page t1 f1 m1 s1) <> (Page t2 f2 m2 s2) =
Page (t1 <> t2)
(f1 <> f2)
(m1 <> m2)
(s1 <> s2)
instance (Monoid m, Monoid a) => Monoid (Page m a) where
mempty = Page mempty mempty mempty mempty
initPage :: Page H.Html T.Text
initPage = Page "Matebeamter" mempty mempty mempty
template
:: Page H.Html T.Text
-> H.Html
-> H.Html
template (Page title favicon meta style) content =
H.docTypeHtml $ do
H.head $ do
H.title $ H.toHtml $ title
meta
favicon
style
H.body $
content

5
src/View.hs Normal file
View file

@ -0,0 +1,5 @@
module View
( module V
) where
import View.Auth as V

12
src/View/Auth.hs Normal file
View file

@ -0,0 +1,12 @@
{-# LANGUAGE OverloadedStrings #-}
module View.Auth where
import qualified Text.Blaze.Html5 as H
import Types
type AuthPage = H.Html
authPage :: AuthPage
authPage = template initPage $ do
H.p $ "Test"