diff --git a/.gitignore b/.gitignore index 99d4a3d3c..5c3dfb89e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ dist* static/tmp/ static/combined/ -config/client_session_key.aes +client_session_key.aes *.hi *.o *.sqlite3 diff --git a/config/favicon.ico b/embedded/favicon.ico similarity index 100% rename from config/favicon.ico rename to embedded/favicon.ico diff --git a/config/robots.txt b/embedded/robots.txt similarity index 100% rename from config/robots.txt rename to embedded/robots.txt diff --git a/config/models b/models similarity index 100% rename from config/models rename to models diff --git a/package.yaml b/package.yaml index 3830186c9..13da5a6b4 100644 --- a/package.yaml +++ b/package.yaml @@ -45,6 +45,10 @@ dependencies: - time - case-insensitive - wai +- cryptonite +- cryptonite-conduit +- base64-bytestring +- memory # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/config/routes b/routes similarity index 86% rename from config/routes rename to routes index d6836884c..6df7b740c 100644 --- a/config/routes +++ b/routes @@ -6,6 +6,4 @@ / HomeR GET POST -/comments CommentR POST - /profile ProfileR GET diff --git a/src/Application.hs b/src/Application.hs index 8017d6f07..a810dc36a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -40,19 +40,18 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, -- Don't forget to add new modules to your cabal file! import Handler.Common import Handler.Home -import Handler.Comment import Handler.Profile -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- comments there for more details. -mkYesodDispatch "App" resourcesApp +mkYesodDispatch "UniWorX" resourcesUniWorX -- | This function allocates resources (such as a database connection pool), -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. -makeFoundation :: AppSettings -> IO App +makeFoundation :: AppSettings -> IO UniWorX makeFoundation appSettings = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. @@ -67,8 +66,8 @@ makeFoundation appSettings = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool = App {..} - -- The App {..} syntax is an example of record wild cards. For more + let mkFoundation appConnPool = UniWorX {..} + -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" @@ -87,14 +86,14 @@ makeFoundation appSettings = do -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. -makeApplication :: App -> IO Application +makeApplication :: UniWorX -> IO Application makeApplication foundation = do logWare <- makeLogWare foundation -- Create the WAI application and apply middlewares appPlain <- toWaiAppPlain foundation return $ logWare $ defaultMiddlewaresNoLogging appPlain -makeLogWare :: App -> IO Middleware +makeLogWare :: UniWorX -> IO Middleware makeLogWare foundation = mkRequestLogger def { outputFormat = @@ -109,7 +108,7 @@ makeLogWare foundation = -- | Warp settings for the given foundation value. -warpSettings :: App -> Settings +warpSettings :: UniWorX -> Settings warpSettings foundation = setPort (appPort $ appSettings foundation) $ setHost (appHost $ appSettings foundation) @@ -126,14 +125,14 @@ warpSettings foundation = -- | For yesod devel, return the Warp settings and WAI Application. getApplicationDev :: IO (Settings, Application) getApplicationDev = do - settings <- getAppSettings + settings <- getAppDevSettings foundation <- makeFoundation settings wsettings <- getDevSettings $ warpSettings foundation app <- makeApplication foundation return (wsettings, app) -getAppSettings :: IO AppSettings -getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv +getAppDevSettings :: IO AppSettings +getAppDevSettings = loadYamlSettings [".dbsettings.yml", "config/test-settings.yml", configSettingsYml] [configSettingsYmlValue] useEnv -- | main function for use by yesod devel develMain :: IO () @@ -163,15 +162,15 @@ appMain = do -------------------------------------------------------------- -- Functions for DevelMain.hs (a way to run the app from GHCi) -------------------------------------------------------------- -getApplicationRepl :: IO (Int, App, Application) +getApplicationRepl :: IO (Int, UniWorX, Application) getApplicationRepl = do - settings <- getAppSettings + settings <- getAppDevSettings foundation <- makeFoundation settings wsettings <- getDevSettings $ warpSettings foundation app1 <- makeApplication foundation return (getPort wsettings, foundation, app1) -shutdownApp :: App -> IO () +shutdownApp :: UniWorX -> IO () shutdownApp _ = return () @@ -181,8 +180,8 @@ shutdownApp _ = return () -- | Run a handler handler :: Handler a -> IO a -handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h +handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h -- | Run DB queries -db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a +db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a db = handler . runDB diff --git a/src/Foundation.hs b/src/Foundation.hs index 9979e7bb6..7936a916f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} module Foundation where @@ -22,11 +23,26 @@ import qualified Yesod.Core.Unsafe as Unsafe import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE +import Data.ByteArray (convert) +import Crypto.Hash (Digest, SHAKE256) +import Crypto.Hash.Conduit (sinkHash) + +import qualified Data.ByteString.Base64.URL as Base64 (encode) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Data.Conduit (($$)) +import Data.Conduit.List (sourceList) + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have -- access to the data present here. -data App = App +data UniWorX = UniWorX { appSettings :: AppSettings , appStatic :: Static -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. @@ -36,7 +52,7 @@ data App = App data MenuItem = MenuItem { menuItemLabel :: Text - , menuItemRoute :: Route App + , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Bool } @@ -54,16 +70,16 @@ data MenuTypes -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- -- This function also generates the following type synonyms: --- type Handler = HandlerT App IO --- type Widget = WidgetT App IO () -mkYesodData "App" $(parseRoutesFile "config/routes") +-- type Handler = HandlerT UniWorX IO +-- type Widget = WidgetT UniWorX IO () +mkYesodData "UniWorX" $(parseRoutesFile "routes") -- | A convenient synonym for creating forms. -type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) +type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. -instance Yesod App where +instance Yesod UniWorX where -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot approot = ApprootRequest $ \app req -> @@ -75,7 +91,7 @@ instance Yesod App where -- default session idle timeout is 120 minutes makeSessionBackend _ = Just <$> defaultClientSessionBackend 120 -- timeout in minutes - "config/client_session_key.aes" + "client_session_key.aes" -- Yesod Middleware allows you to run code before and after each handler function. -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. @@ -142,7 +158,6 @@ instance Yesod App where -- Routes not requiring authentication. isAuthorized (AuthR _) _ = return Authorized - isAuthorized CommentR _ = return Authorized isAuthorized HomeR _ = return Authorized isAuthorized FaviconR _ = return Authorized isAuthorized RobotsR _ = return Authorized @@ -166,8 +181,19 @@ instance Yesod App where mime content where - -- Generate a unique filename based on the content itself - genFileName lbs = "autogen-" ++ base64md5 lbs + -- Generate a unique filename based on the content itself, this is used + -- for deduplication so a collision resistant hash function is required + -- + -- SHA-3 (SHAKE256) seemed to be a future-proof choice + -- + -- Length of hash is 144 bits instead of MD5's 128, so as to avoid + -- padding after base64-conversion + genFileName lbs = Text.unpack + . Text.decodeUtf8 + . Base64.encode + . (convert :: Digest (SHAKE256 144) -> ByteString) + . runIdentity + $ sourceList (Lazy.ByteString.toChunks lbs) $$ sinkHash -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. @@ -179,23 +205,21 @@ instance Yesod App where makeLogger = return . appLogger -- Define breadcrumbs. -instance YesodBreadcrumbs App where +instance YesodBreadcrumbs UniWorX where breadcrumb HomeR = return ("Home", Nothing) breadcrumb (AuthR _) = return ("Login", Just HomeR) breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb _ = return ("home", Nothing) -- How to run database actions. -instance YesodPersist App where - type YesodPersistBackend App = SqlBackend - runDB action = do - master <- getYesod - runSqlPool action $ appConnPool master -instance YesodPersistRunner App where +instance YesodPersist UniWorX where + type YesodPersistBackend UniWorX = SqlBackend + runDB action = runSqlPool action =<< appConnPool <$> getYesod +instance YesodPersistRunner UniWorX where getDBRunner = defaultGetDBRunner appConnPool -instance YesodAuth App where - type AuthId App = UserId +instance YesodAuth UniWorX where + type AuthId UniWorX = UserId -- Where to send a user after successful login loginDest _ = HomeR @@ -228,20 +252,20 @@ isAuthenticated = do Nothing -> Unauthorized "You must login to access this page" Just _ -> Authorized -instance YesodAuthPersist App +instance YesodAuthPersist UniWorX -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. -instance RenderMessage App FormMessage where +instance RenderMessage UniWorX FormMessage where renderMessage _ _ = defaultFormMessage -- Useful when writing code that is re-usable outside of the Handler context. -- An example is background jobs that send email. -- This can also be useful for writing code that works across multiple Yesod applications. -instance HasHttpManager App where +instance HasHttpManager UniWorX where getHttpManager = appHttpManager -unsafeHandler :: App -> Handler a -> IO a +unsafeHandler :: UniWorX -> Handler a -> IO a unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- Note: Some functionality previously present in the scaffolding has been diff --git a/src/Handler/Comment.hs b/src/Handler/Comment.hs deleted file mode 100644 index edb20a8ab..000000000 --- a/src/Handler/Comment.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Handler.Comment where - -import Import - -postCommentR :: Handler Value -postCommentR = do - -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid. - -- (The ToJSON and FromJSON instances are derived in the config/models file). - comment <- (requireJsonBody :: Handler Comment) - - -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication. - maybeCurrentUserId <- maybeAuthId - let comment' = comment { commentUserId = maybeCurrentUserId } - - insertedComment <- runDB $ insertEntity comment' - returnJson insertedComment diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs index 6783f8afb..2119bfb06 100644 --- a/src/Handler/Common.hs +++ b/src/Handler/Common.hs @@ -15,8 +15,8 @@ import Import getFaviconR :: Handler TypedContent getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month return $ TypedContent "image/x-icon" - $ toContent $(embedFile "config/favicon.ico") + $ toContent $(embedFile "embedded/favicon.ico") getRobotsR :: Handler TypedContent getRobotsR = return $ TypedContent typePlain - $ toContent $(embedFile "config/robots.txt") + $ toContent $(embedFile "embedded/robots.txt") diff --git a/src/Import.hs b/src/Import.hs index 25ed1f7be..a10200156 100644 --- a/src/Import.hs +++ b/src/Import.hs @@ -4,4 +4,3 @@ module Import import Foundation as Import import Import.NoFoundation as Import -import ModelData as Import diff --git a/src/Model.hs b/src/Model.hs index c84945443..dedba802f 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -7,20 +7,23 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -module Model where +module Model + ( module Model + , module Model.Types + ) where import ClassyPrelude.Yesod import Database.Persist.Quasi -- import Data.Time -- import Data.ByteString -import ModelData +import Model.Types -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkMigrate "migrateAll"] - $(persistFileWith lowerCaseSettings "config/models") + $(persistFileWith lowerCaseSettings "models") instance Show Term where show = ClassyPrelude.Yesod.unpack . termName diff --git a/src/ModelData.hs b/src/Model/Types.hs similarity index 96% rename from src/ModelData.hs rename to src/Model/Types.hs index 620feff5c..be40723b9 100644 --- a/src/ModelData.hs +++ b/src/Model/Types.hs @@ -1,6 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} -module ModelData where +module Model.Types where import Database.Persist.TH @@ -28,4 +28,4 @@ instance PersistField Term where fromPersistValue (Term {season, year}) = undefined sqlType _ = SqlInteger isNullable _ = False --} \ No newline at end of file +-} diff --git a/templates/homepage.julius b/templates/homepage.julius index 865882ec9..c04a285e6 100644 --- a/templates/homepage.julius +++ b/templates/homepage.julius @@ -13,7 +13,7 @@ $(function() { // Make an AJAX request to the server to create a new comment $.ajax({ - url: '@{CommentR}', + url: 'null.invalid', type: 'POST', contentType: "application/json", data: JSON.stringify({ diff --git a/test/Handler/CommentSpec.hs b/test/Handler/CommentSpec.hs deleted file mode 100644 index 0b5225cd8..000000000 --- a/test/Handler/CommentSpec.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module Handler.CommentSpec (spec) where - -import TestImport -import Data.Aeson - -spec :: Spec -spec = withApp $ do - describe "valid request" $ do - it "gives a 200" $ do - get HomeR - statusIs 200 - - let message = "My message" :: Text - body = object [ "message" .= message ] - encoded = encode body - - request $ do - setMethod "POST" - setUrl CommentR - setRequestBody encoded - addRequestHeader ("Content-Type", "application/json") - - statusIs 200 - - [Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] [] - assertEq "Should have " comment (Comment message Nothing) - - describe "invalid requests" $ do - it "400s when the JSON body is invalid" $ do - get HomeR - - let body = object [ "foo" .= ("My message" :: Value) ] - - request $ do - setMethod "POST" - setUrl CommentR - setRequestBody $ encode body - addRequestHeader ("Content-Type", "application/json") - - statusIs 400 - diff --git a/test/TestImport.hs b/test/TestImport.hs index 66626ba0d..47cd584ad 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -19,24 +19,24 @@ import Yesod.Auth as X import Yesod.Test as X import Yesod.Core.Unsafe (fakeHandlerGetLogger) -runDB :: SqlPersistM a -> YesodExample App a +runDB :: SqlPersistM a -> YesodExample UniWorX a runDB query = do app <- getTestYesod liftIO $ runDBWithApp app query -runDBWithApp :: App -> SqlPersistM a -> IO a +runDBWithApp :: UniWorX -> SqlPersistM a -> IO a runDBWithApp app query = runSqlPersistMPool query (appConnPool app) -runHandler :: Handler a -> YesodExample App a +runHandler :: Handler a -> YesodExample UniWorX a runHandler handler = do app <- getTestYesod fakeHandlerGetLogger appLogger app handler -withApp :: SpecWith (TestApp App) -> Spec +withApp :: SpecWith (TestApp UniWorX) -> Spec withApp = before $ do settings <- loadYamlSettings - ["config/test-settings.yml", "config/settings.yml"] + [".dbsettings.yml", "config/test-settings.yml", "config/settings.yml"] [] useEnv foundation <- makeFoundation settings @@ -47,7 +47,7 @@ withApp = before $ do -- This function will truncate all of the tables in your database. -- 'withApp' calls it before each test, creating a clean environment for each -- spec to run in. -wipeDB :: App -> IO () +wipeDB :: UniWorX -> IO () wipeDB app = runDBWithApp app $ do tables <- getTables sqlBackend <- ask @@ -69,7 +69,7 @@ getTables = do -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag -- being set in test-settings.yaml, which enables dummy authentication in -- Foundation.hs -authenticateAs :: Entity User -> YesodExample App () +authenticateAs :: Entity User -> YesodExample UniWorX () authenticateAs (Entity _ u) = do request $ do setMethod "POST" @@ -78,7 +78,7 @@ authenticateAs (Entity _ u) = do -- | Create a user. The dummy email entry helps to confirm that foreign-key -- checking is switched off in wipeDB for those database backends which need it. -createUser :: Text -> YesodExample App (Entity User) +createUser :: Text -> YesodExample UniWorX (Entity User) createUser ident = runDB $ do user <- insertEntity User { userIdent = ident