dfsek.com/src/Application.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Application where

import ClassyPrelude.Yesod (newManager, runMigration, UTCTime)
import Control.Monad.Logger (runStdoutLoggingT)
import Data.Int (Int64)
import Data.Yaml.Aeson (decodeFileEither)
import Database.Persist.Sqlite (ConnectionPool, SqlBackend, createSqlitePool, runSqlPersistMPool, runSqlPool)
import DfsekConfig
import GenericOIDC (oidcAuth')
import System.Directory (createDirectoryIfMissing)
import Text.Hamlet (hamletFile)
import URI.ByteString ()
import qualified Web.ClientSession as CS
import Yesod
import Yesod.Auth
import Yesod.Auth.OAuth2.Prelude
import Yesod.Static
import Prelude

data Dfsek = Dfsek
  { httpManager :: Manager,
    config :: DfsekConfig,
    getStatic :: Static,
    getWellKnown :: Static,
    connPool :: ConnectionPool
  }

share
  [mkPersist sqlSettings, mkMigrate "migrateAll"]
  [persistLowerCase|
Upload
  flake Int64
  files [String]
  user Text
  uploaded UTCTime
|]

mkYesod
  "Dfsek"
  [parseRoutes|
/auth                  AuthR Auth getAuth
/                      HomeR GET
/about                 AboutR GET
/recycling             RecyclingR GET
/blog                  BlogR GET
/blog/rivers           BlogTEMP_RIVERS GET
/projects              ProjectsR GET
/static                StaticR Static getStatic
/.well-known           WellKnownR Static getWellKnown
|]

data MenuItem = MenuItem
  { menuItemLabel :: Text,
    menuItemRoute :: Route Dfsek,
    subItems :: [ChildItem]
  }

data ChildItem = ChildItem
  { childItemLabel :: Text,
    childItemRoute :: Route Dfsek
  }

instance Yesod Dfsek where
  approot = ApprootMaster $ host . config
  authRoute _ = Just $ AuthR LoginR

  isAuthorized _ _ = return Authorized
  makeSessionBackend _ = Just <$> defaultClientSessionBackend (7 * 24 * 60) CS.defaultKeyFile
  defaultLayout :: Widget -> Handler Html
  defaultLayout widget = do
    mmsg <- getMessage

    mcurrentRoute <- getCurrentRoute

    let menuItems =
          [ MenuItem
              { menuItemLabel = "Home",
                menuItemRoute = HomeR,
                subItems = []
              },
            MenuItem
              { menuItemLabel = "About",
                menuItemRoute = AboutR,
                subItems = []
              },
            MenuItem
              { menuItemLabel = "Projects",
                menuItemRoute = ProjectsR,
                subItems = []
              },
            MenuItem
              { menuItemLabel = "Blog",
                menuItemRoute = BlogR,
                subItems = [
                  ChildItem {
                  childItemLabel = "Procedural Rivers",
                  childItemRoute = BlogTEMP_RIVERS
                  }
                  ]
              }
          ]

    pc <- widgetToPageContent $ do
      user <- maybeAuthId
      $(widgetFile "default-layout")
    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")

-- Define breadcrumbs.
instance YesodBreadcrumbs Dfsek where
  breadcrumb ::
    -- | The route the user is visiting currently.
    Route Dfsek ->
    Handler (Text, Maybe (Route Dfsek))
  breadcrumb HomeR = return ("Home", Nothing)
  breadcrumb _ = return ("home", Nothing)

isSignedIn :: HandlerFor Dfsek AuthResult
isSignedIn = do
  user <- maybeAuthId
  return $ case user of
    Nothing -> AuthenticationRequired
    Just _ -> Authorized

instance YesodAuth Dfsek where
  type AuthId Dfsek = Text
  authenticate = return . Authenticated . credsIdent
  loginDest _ = HomeR
  logoutDest _ = HomeR
  authPlugins y = [oidcAuth' $ oidc $ config y]
  maybeAuthId = lookupSession "_ID"

instance RenderMessage Dfsek FormMessage where
  renderMessage _ _ = defaultFormMessage

instance YesodPersist Dfsek where
  type YesodPersistBackend Dfsek = SqlBackend
  runDB f = do
    dfsek <- getYesod
    let pool = connPool dfsek
    runSqlPool f pool

getHomeR :: Handler Html
getHomeR = defaultLayout (setTitle "dfsek.com" >> $(whamletFile "pages/home.hamlet"))

getAboutR :: Handler Html
getAboutR = defaultLayout (setTitle "dfsek.com - About" >> $(whamletFile "pages/about.hamlet"))

getProjectsR :: Handler Html
getProjectsR = defaultLayout (setTitle "dfsek.com - My Projects" >> $(whamletFile "pages/projects.hamlet"))

getRecyclingR :: Handler Html
getRecyclingR = defaultLayout (setTitle "dfsek.com - Electronics Recycling Services" >> $(whamletFile "pages/recycling.hamlet"))

getBlogR :: Handler Html
getBlogR = defaultLayout (setTitle "dfsek.com - Blog" >> $(whamletFile "pages/blog.hamlet"))

getBlogTEMP_RIVERS :: Handler Html
getBlogTEMP_RIVERS = defaultLayout (setTitle "dfsek.com - Blog - Procedural River Generation" >> $(whamletFile "static_blog/noise_rivers.hamlet"))

appMain :: IO ()
appMain = do
  c' <- decodeFileEither "config.yml"
  case c' of
    Left e -> error $ "Could not parse config file: " <> show e
    Right conf -> do
      pool <- runStdoutLoggingT $ createSqlitePool (sqlite_file (database conf)) $ connection_count (database conf)
      runSqlPersistMPool (runMigration migrateAll) pool

      let contentDir = content_directory conf
      createDirectoryIfMissing True contentDir
      putStrLn $ "Static directory: " <> contentDir
      
      let wellKnownDir = well_known_directory conf
      createDirectoryIfMissing True wellKnownDir
      putStrLn $ "well-known directory: " <> wellKnownDir

      staticRoute <- static contentDir
      staticWellKnown <- static wellKnownDir

      putStrLn $ "Launching application at " <> show (host conf)

      manager <- newManager

      warp 3001 $ Dfsek manager conf staticRoute staticWellKnown pool