├── .gitignore ├── LICENSE ├── app ├── DevelMain.hs ├── devel.hs └── main.hs ├── cabal.config ├── config ├── favicon.ico ├── keter.yaml ├── models ├── robots.txt ├── routes ├── settings.yml └── sqlite.yml ├── deploy └── Procfile ├── dohaskell.cabal ├── messages └── en.msg ├── migrations ├── 1.sql ├── 2.sql ├── 3.sql ├── 4.sql ├── 5.sql └── 6.sql ├── resources-dump.yaml ├── src ├── Application.hs ├── Data │ └── Tree │ │ └── Extra.hs ├── Database │ └── Persist │ │ └── Class │ │ └── Extra.hs ├── Foundation.hs ├── Handler │ ├── About.hs │ ├── Api │ │ └── Resource.hs │ ├── Browse.hs │ ├── Common.hs │ ├── EditResourceRequest.hs │ ├── Feed.hs │ ├── ReqEditsHub.hs │ ├── Resource.hs │ ├── Submit.hs │ ├── User.hs │ └── Utils.hs ├── Import.hs ├── Import │ └── NoFoundation.hs ├── Model.hs ├── Model │ ├── Author.hs │ ├── Browse.hs │ ├── Collection.hs │ ├── Feed.hs │ ├── Feed │ │ └── Internal.hs │ ├── List.hs │ ├── Resource.hs │ ├── Resource │ │ └── Internal.hs │ ├── ResourceEdit.hs │ ├── Tag.hs │ ├── User.hs │ └── Utils.hs ├── Settings.hs ├── Settings │ └── StaticFiles.hs ├── View │ ├── Browse.hs │ ├── Feed.hs │ ├── Navbar.hs │ ├── Resource.hs │ └── User.hs └── Yesod │ └── Form │ └── Types │ └── Extra.hs ├── stack.yaml ├── static ├── css │ ├── bootstrap.css │ └── normalize.css └── img │ ├── circle-outline.png │ ├── circle.png │ ├── edit.png │ ├── glyphicons-halflings-white.png │ ├── glyphicons-halflings.png │ ├── lambda.png │ ├── right-arrow.png │ ├── star-outline.png │ └── star.png ├── templates ├── about.cassius ├── about.hamlet ├── browse.cassius ├── browse.hamlet ├── browse.julius ├── default-layout-wrapper.hamlet ├── default-layout.cassius ├── default-layout.hamlet ├── feeds.cassius ├── feeds.hamlet ├── navbar.cassius ├── navbar.hamlet ├── requested-edits-hub.cassius ├── requested-edits-hub.hamlet ├── resource-comments.hamlet ├── resource-info.cassius ├── resource-info.hamlet ├── resource-list-logged-in.julius ├── resource-list-not-logged-in.julius ├── resource-list.cassius ├── resource-list.hamlet ├── resource.cassius ├── resource.hamlet ├── submit.cassius ├── submit.hamlet ├── user.cassius └── user.hamlet └── tests ├── HomeTest.hs ├── TestImport.hs └── main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | static/tmp/ 3 | static/combined/ 4 | config/client_session_key.aes 5 | *.hi 6 | *.o 7 | *.sqlite3 8 | .hsenv* 9 | cabal-dev/ 10 | yesod-devel/ 11 | .cabal-sandbox 12 | cabal.sandbox.config 13 | .DS_Store 14 | *.swp 15 | .ghci 16 | codex.tags 17 | hscope.out 18 | tags 19 | .stack-work/ 20 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Mitchell Rosen 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Mitchell Rosen nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /app/DevelMain.hs: -------------------------------------------------------------------------------- 1 | -- | Running your app inside GHCi. 2 | -- 3 | -- To start up GHCi for usage with Yesod, first make sure you are in dev mode: 4 | -- 5 | -- > cabal configure -fdev 6 | -- 7 | -- Note that @yesod devel@ automatically sets the dev flag. 8 | -- Now launch the repl: 9 | -- 10 | -- > cabal repl --ghc-options="-O0 -fobject-code" 11 | -- 12 | -- To start your app, run: 13 | -- 14 | -- > :l DevelMain 15 | -- > DevelMain.update 16 | -- 17 | -- You can also call @DevelMain.shutdown@ to stop the app 18 | -- 19 | -- You will need to add the foreign-store package to your .cabal file. 20 | -- It is very light-weight. 21 | -- 22 | -- If you don't use cabal repl, you will need 23 | -- to run the following in GHCi or to add it to 24 | -- your .ghci file. 25 | -- 26 | -- :set -DDEVELOPMENT 27 | -- 28 | -- There is more information about this approach, 29 | -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci 30 | 31 | module DevelMain where 32 | 33 | import Prelude 34 | import Application (getApplicationRepl, shutdownApp) 35 | 36 | import Control.Exception (finally) 37 | import Control.Monad ((>=>)) 38 | import Control.Concurrent 39 | import Data.IORef 40 | import Foreign.Store 41 | import Network.Wai.Handler.Warp 42 | import GHC.Word 43 | 44 | -- | Start or restart the server. 45 | -- newStore is from foreign-store. 46 | -- A Store holds onto some data across ghci reloads 47 | update :: IO () 48 | update = do 49 | mtidStore <- lookupStore tidStoreNum 50 | case mtidStore of 51 | -- no server running 52 | Nothing -> do 53 | done <- storeAction doneStore newEmptyMVar 54 | tid <- start done 55 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 56 | return () 57 | -- server is already running 58 | Just tidStore -> restartAppInNewThread tidStore 59 | where 60 | doneStore :: Store (MVar ()) 61 | doneStore = Store 0 62 | 63 | -- shut the server down with killThread and wait for the done signal 64 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 65 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 66 | killThread tid 67 | withStore doneStore takeMVar 68 | readStore doneStore >>= start 69 | 70 | 71 | -- | Start the server in a separate thread. 72 | start :: MVar () -- ^ Written to when the thread is killed. 73 | -> IO ThreadId 74 | start done = do 75 | (port, site, app) <- getApplicationRepl 76 | forkIO (finally (runSettings (setPort port defaultSettings) app) 77 | -- Note that this implies concurrency 78 | -- between shutdownApp and the next app that is starting. 79 | -- Normally this should be fine 80 | (putMVar done () >> shutdownApp site)) 81 | 82 | -- | kill the server 83 | shutdown :: IO () 84 | shutdown = do 85 | mtidStore <- lookupStore tidStoreNum 86 | case mtidStore of 87 | -- no server running 88 | Nothing -> putStrLn "no Yesod app running" 89 | Just tidStore -> do 90 | withStore tidStore $ readIORef >=> killThread 91 | putStrLn "Yesod app is shutdown" 92 | 93 | tidStoreNum :: Word32 94 | tidStoreNum = 1 95 | 96 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 97 | modifyStoredIORef store f = withStore store $ \ref -> do 98 | v <- readIORef ref 99 | f v >>= writeIORef ref 100 | 101 | -------------------------------------------------------------------------------- /app/devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "dohaskell" Application (develMain) 3 | import Prelude (IO) 4 | 5 | main :: IO () 6 | main = develMain 7 | -------------------------------------------------------------------------------- /app/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Application (appMain) 3 | 4 | main :: IO () 5 | main = appMain 6 | -------------------------------------------------------------------------------- /cabal.config: -------------------------------------------------------------------------------- 1 | constraints: HTTP ==4000.2.18, 2 | JuicyPixels ==3.1.7.1, 3 | SHA ==1.6.4.1, 4 | aeson ==0.7.0.6, 5 | ansi-terminal ==0.6.1.1, 6 | ansi-wl-pprint ==0.6.7.1, 7 | array ==0.5.0.0, 8 | asn1-encoding ==0.8.1.3, 9 | asn1-parse ==0.8.1, 10 | asn1-types ==0.2.3, 11 | async ==2.0.1.5, 12 | attoparsec ==0.12.1.1, 13 | attoparsec-conduit ==1.1.0, 14 | authenticate ==1.3.2.10, 15 | base ==4.7.0.1, 16 | base16-bytestring ==0.1.1.6, 17 | base64-bytestring ==1.0.0.1, 18 | bifunctors ==4.1.1.1, 19 | binary ==0.7.1.0, 20 | blaze-builder ==0.3.3.2, 21 | blaze-builder-conduit ==1.1.0, 22 | blaze-html ==0.7.0.2, 23 | blaze-markup ==0.6.1.0, 24 | byteable ==0.1.1, 25 | byteorder ==1.0.4, 26 | bytestring ==0.10.4.0, 27 | case-insensitive ==1.2.0.0, 28 | cereal ==0.4.0.1, 29 | cipher-aes ==0.2.8, 30 | cipher-des ==0.0.6, 31 | cipher-rc4 ==0.1.4, 32 | clientsession ==0.9.0.5, 33 | comonad ==4.2.2, 34 | conduit ==1.1.7, 35 | conduit-extra ==1.1.3.4, 36 | connection ==0.2.3, 37 | containers ==0.5.5.1, 38 | contravariant ==1.2, 39 | cookie ==0.4.1.3, 40 | cprng-aes ==0.5.2, 41 | crypto-api ==0.13, 42 | crypto-cipher-types ==0.0.9, 43 | crypto-numbers ==0.2.3, 44 | crypto-pubkey ==0.2.4, 45 | crypto-pubkey-types ==0.4.2.2, 46 | crypto-random ==0.0.7, 47 | cryptohash ==0.11.6, 48 | cryptohash-conduit ==0.1.1, 49 | css-text ==0.1.2.1, 50 | data-default ==0.5.3, 51 | data-default-class ==0.0.1, 52 | data-default-instances-base ==0.0.1, 53 | data-default-instances-containers ==0.0.1, 54 | data-default-instances-dlist ==0.0.1, 55 | data-default-instances-old-locale ==0.0.1, 56 | deepseq ==1.3.0.2, 57 | deepseq-generics ==0.1.1.1, 58 | digest ==0.0.1.2, 59 | directory ==1.2.1.0, 60 | distributive ==0.4.4, 61 | dlist ==0.7.1, 62 | easy-file ==0.2.0, 63 | email-validate ==2.0.1, 64 | entropy ==0.3.2, 65 | esqueleto ==1.4.4, 66 | exceptions ==0.6.1, 67 | extensible-exceptions ==0.1.1.4, 68 | fast-logger ==2.1.5, 69 | feed ==0.3.9.2, 70 | file-embed ==0.0.7, 71 | filepath ==1.3.0.2, 72 | free ==4.9, 73 | ghc-prim ==0.3.1.0, 74 | haddock-library ==1.1.1, 75 | hamlet ==1.2.0, 76 | hashable ==1.2.2.0, 77 | highlighting-kate ==0.5.9, 78 | hjsmin ==0.1.4.7, 79 | hslua ==0.3.13, 80 | http-client ==0.3.8, 81 | http-client-tls ==0.2.2, 82 | http-conduit ==2.1.4.2, 83 | http-date ==0.0.4, 84 | http-types ==0.8.5, 85 | integer-gmp ==0.5.1.0, 86 | language-javascript ==0.5.13, 87 | lens ==4.4.0.1, 88 | lens-aeson ==1, 89 | lifted-base ==0.2.3.0, 90 | mime-mail ==0.4.5.2, 91 | mime-types ==0.1.0.4, 92 | mmorph ==1.0.4, 93 | monad-control ==0.3.3.0, 94 | monad-logger ==0.3.7.2, 95 | monad-loops ==0.4.2.1, 96 | mtl ==2.2.1, 97 | nats ==0.2, 98 | network ==2.5.0.0, 99 | network-conduit ==1.1.0, 100 | network-uri ==2.6.0.0, 101 | old-locale ==1.0.0.6, 102 | old-time ==1.1.0.2, 103 | optparse-applicative ==0.9.1.1, 104 | pandoc ==1.13.1, 105 | pandoc-types ==1.12.4.1, 106 | parallel ==3.2.0.4, 107 | parsec ==3.1.5, 108 | path-pieces ==0.1.4, 109 | pem ==0.2.2, 110 | persistent ==1.3.3, 111 | persistent-sqlite ==1.3.0.5, 112 | persistent-template ==1.3.2.2, 113 | prelude-extras ==0.4, 114 | pretty ==1.1.1.1, 115 | primitive ==0.5.3.0, 116 | process ==1.2.0.0, 117 | profunctors ==4.2.0.1, 118 | publicsuffixlist ==0.1, 119 | random ==1.0.1.3, 120 | reflection ==1.5.1, 121 | regex-base ==0.93.2, 122 | regex-pcre-builtin ==0.94.4.8.8.35, 123 | resource-pool ==0.2.3.0, 124 | resourcet ==1.1.2.3, 125 | rts ==1.0, 126 | safe ==0.3.8, 127 | scientific ==0.3.3.0, 128 | securemem ==0.1.3, 129 | semigroupoids ==4.2, 130 | semigroups ==0.15.2, 131 | shakespeare ==2.0.1.1, 132 | shakespeare-css ==1.1.0, 133 | shakespeare-i18n ==1.1.0, 134 | shakespeare-js ==1.3.0, 135 | silently ==1.2.4.1, 136 | simple-sendfile ==0.2.17, 137 | skein ==1.0.9, 138 | socks ==0.5.4, 139 | split ==0.2.2, 140 | stm ==2.4.3, 141 | stm-chans ==3.0.0.2, 142 | streaming-commons ==0.1.4.2, 143 | stringsearch ==0.3.6.5, 144 | syb ==0.4.2, 145 | system-fileio ==0.3.14, 146 | system-filepath ==0.4.12, 147 | tagged ==0.7.2, 148 | tagsoup ==0.13.2, 149 | tagstream-conduit ==0.5.5.1, 150 | template-haskell ==2.9.0.0, 151 | temporary ==1.2.0.3, 152 | texmath ==0.8, 153 | text ==1.1.1.3, 154 | time ==1.4.2, 155 | tls ==1.2.8, 156 | transformers ==0.4.1.0, 157 | transformers-base ==0.4.3, 158 | transformers-compat ==0.3.3.4, 159 | unix ==2.7.0.1, 160 | unix-compat ==0.4.1.3, 161 | unix-time ==0.3.3, 162 | unordered-containers ==0.2.5.0, 163 | utf8-string ==0.3.8, 164 | vault ==0.3.0.3, 165 | vector ==0.10.11.0, 166 | void ==0.6.1, 167 | wai ==2.1.0.3, 168 | wai-app-static ==2.0.1, 169 | wai-extra ==2.1.1.3, 170 | wai-logger ==2.1.2, 171 | warp ==2.1.5.2, 172 | word8 ==0.1.1, 173 | wreq ==0.2.0.0, 174 | x509 ==1.4.11, 175 | x509-store ==1.4.4, 176 | x509-system ==1.4.5, 177 | x509-validation ==1.5.0, 178 | xml ==1.3.13, 179 | xml-conduit ==1.2.2, 180 | xml-types ==0.3.4, 181 | xss-sanitize ==0.3.5.4, 182 | yaml ==0.8.9.1, 183 | yesod ==1.2.6.1, 184 | yesod-auth ==1.3.4.3, 185 | yesod-core ==1.2.19.2, 186 | yesod-form ==1.3.15.3, 187 | yesod-markdown ==0.9.2, 188 | yesod-persistent ==1.2.3.1, 189 | yesod-routes ==1.2.0.7, 190 | yesod-static ==1.2.4, 191 | zip-archive ==0.2.3.4, 192 | zlib ==0.5.4.1, 193 | zlib-conduit ==1.1.0 194 | -------------------------------------------------------------------------------- /config/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/config/favicon.ico -------------------------------------------------------------------------------- /config/keter.yaml: -------------------------------------------------------------------------------- 1 | # After you've edited this file, remove the following line to allow 2 | # `yesod keter` to build your bundle. 3 | user-edited: false 4 | 5 | # A Keter app is composed of 1 or more stanzas. The main stanza will define our 6 | # web application. See the Keter documentation for more information on 7 | # available stanzas. 8 | stanzas: 9 | 10 | # Your Yesod application. 11 | - type: webapp 12 | 13 | # Name of your executable. You are unlikely to need to change this. 14 | # Note that all file paths are relative to the keter.yml file. 15 | exec: ../dist/build/dohaskell/dohaskell 16 | 17 | # Command line options passed to your application. 18 | args: [] 19 | 20 | hosts: 21 | # You can specify one or more hostnames for your application to respond 22 | # to. The primary hostname will be used for generating your application 23 | # root. 24 | - www.dohaskell.com 25 | 26 | # Enable to force Keter to redirect to https 27 | # Can be added to any stanza 28 | requires-secure: false 29 | 30 | # Static files. 31 | - type: static-files 32 | hosts: 33 | - static.dohaskell.com 34 | root: ../static 35 | 36 | # Uncomment to turn on directory listings. 37 | # directory-listing: true 38 | 39 | # Redirect plain domain name to www. 40 | - type: redirect 41 | 42 | hosts: 43 | - dohaskell.com 44 | actions: 45 | - host: www.dohaskell.com 46 | # secure: false 47 | # port: 80 48 | 49 | # Uncomment to switch to a non-permanent redirect. 50 | # status: 303 51 | 52 | # Use the following to automatically copy your bundle upon creation via `yesod 53 | # keter`. Uses `scp` internally, so you can set it to a remote destination 54 | # copy-to: user@host:/opt/keter/incoming/ 55 | 56 | # You can pass arguments to `scp` used above. This example limits bandwidth to 57 | # 1024 Kbit/s and uses port 2222 instead of the default 22 58 | # copy-to-args: 59 | # - "-l 1024" 60 | # - "-P 2222" 61 | 62 | # If you would like to have Keter automatically create a PostgreSQL database 63 | # and set appropriate environment variables for it to be discovered, uncomment 64 | # the following line. 65 | # plugins: 66 | # postgres: true 67 | -------------------------------------------------------------------------------- /config/models: -------------------------------------------------------------------------------- 1 | -- A user. Users have unique names (email addresses), which are not publicly 2 | -- visible. Users may change their public name at any time, and there is no 3 | -- uniqueness constraint. 4 | User 5 | name Text -- User "name" (credentials used to log in, i.e. an email addr). 6 | displayName Text -- Defaults to "anonymous". Not unique. 7 | isAdministrator Bool 8 | created UTCTime default=CURRENT_TIMESTAMP 9 | UniqueUserName name 10 | deriving Typeable 11 | 12 | -- A list of resources, whose database entry is shared by all users who happen 13 | -- to have made a list of that name. There is one built-in list ("grokked") that 14 | -- users can easily add items to. All other lists (e.g. "to read" or 15 | -- "favorites") are created on the fly by adding one resource to them. 16 | List 17 | name Text 18 | UniqueList name 19 | 20 | -- A single Resource in a User's List. 21 | ListItem 22 | userId UserId 23 | listId ListId 24 | resId ResourceId 25 | timestamp UTCTime 26 | UniqueListItem userId listId resId 27 | 28 | Resource 29 | title Text 30 | url Text 31 | published Int Maybe 32 | type ResourceType 33 | userId UserId 34 | posted UTCTime 35 | UniqueResourceUrl url 36 | deriving Eq Ord 37 | 38 | Tag 39 | name Text 40 | UniqueTag name 41 | deriving Eq Ord 42 | 43 | -- A Resource can have one or more Tags. 44 | -- TODO: rename ResTag 45 | ResourceTag 46 | resId ResourceId 47 | tagId TagId 48 | UniqueResourceTag resId tagId 49 | 50 | Collection 51 | name Text 52 | UniqueCollection name 53 | 54 | -- A Resource can belong to zero or more Collections. 55 | ResCollection 56 | resId ResourceId 57 | colId CollectionId 58 | UniqueResCollection resId colId 59 | 60 | Author 61 | name Text 62 | UniqueAuthor name 63 | deriving Eq Ord 64 | 65 | -- A Resource can have zero or more Authors, order matters. 66 | ResAuthor 67 | resId ResourceId 68 | authId AuthorId 69 | ord Int -- starts at 0 70 | UniqueResAuthor resId authId 71 | 72 | -- A question/answer pair, for a Resource. 73 | -- QuestionAnswer 74 | -- quesText Markdown 75 | -- answText Markdown 76 | -- resId ResourceId 77 | 78 | -- Caveat: can't have a uniqueness constraint on a NULLABLE field. This means 79 | -- there may be two pending edits for the same published year change. Oh well. 80 | EditPublished 81 | resId ResourceId 82 | published Int Maybe 83 | 84 | EditTitle 85 | resId ResourceId 86 | title Text 87 | UniqueEditTitle resId title 88 | 89 | EditType 90 | resId ResourceId 91 | type ResourceType 92 | UniqueEditType resId type 93 | 94 | EditAddTag 95 | resId ResourceId 96 | text Text 97 | UniqueEditAddTag resId text 98 | 99 | EditRemoveTag 100 | resId ResourceId 101 | text Text 102 | UniqueEditRemoveTag resId text 103 | 104 | EditAddCollection 105 | resId ResourceId 106 | name Text 107 | UniqueEditAddCollection resId name 108 | 109 | EditRemoveCollection 110 | resId ResourceId 111 | name Text 112 | UniqueEditRemoveCollection resId name 113 | 114 | -- An EditAuthors is essentially a new list of authors, to be shown to the resource 115 | -- owner as one big blob (he/she will have to figure out what's changed). 116 | -- 117 | -- Editing authors is treated a little differently than editing tags for two reasons: 118 | -- 119 | -- 1. Editing authors will be much less frequent, and there will be fewer authors 120 | -- than tags, so it's not as necessary to see individual add/remove author 121 | -- requests. 122 | -- 123 | -- 2. Author order matters, so inundating the resource maintainer with a bunch of 124 | -- ordering-related edits will cause more confusion than just displaying the list 125 | -- of authors raw and letting them figure it out. 126 | -- 127 | -- Consider changing "foo, bar, baz" to "bar, baz". If we had separate EditAddAuthor, 128 | -- EditRemoveAuthor, and EditChangeAuthorOrdinal requests, this would mandate the 129 | -- acceptance/denial of three separate edits: remove foo, change bar ordinal from 130 | -- 2 to 1, and change baz ordinal from 3 to 2. 131 | EditAuthors 132 | resId ResourceId 133 | authors [Text] 134 | UniqueEditAuthors resId authors 135 | 136 | Feed 137 | type FeedType 138 | title Text 139 | url Text 140 | lastModified ByteString 141 | etag ByteString 142 | contents ByteString 143 | UniqueFeed url 144 | -------------------------------------------------------------------------------- /config/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /config/routes: -------------------------------------------------------------------------------- 1 | /static StaticR Static appStatic 2 | /auth AuthR Auth getAuth 3 | 4 | /favicon.ico FaviconR GET 5 | /robots.txt RobotsR GET 6 | 7 | / HomeR GET 8 | /about AboutR GET 9 | /submit SubmitR GET POST 10 | 11 | /feed FeedR GET 12 | /feeds FeedsR GET 13 | 14 | -- Careful changing these routes! We hit them from JS. 15 | /author/#Text AuthorR GET 16 | /collection/#Text CollectionR GET 17 | /tag/#Text TagR GET 18 | /type/#Text TypeR GET 19 | 20 | /browse/authors BrowseAuthorsR GET 21 | /browse/collections BrowseCollectionsR GET 22 | /browse/resources BrowseResourcesR GET 23 | /browse/tags BrowseTagsR GET 24 | /browse/type BrowseTypesR GET 25 | 26 | /u/#UserId UserR GET POST 27 | /u/#UserId/edits ReqEditsHubR GET 28 | /u/#UserId/submitted UserSubmittedR GET 29 | -- Users can see other Users' Lists via this route; it's equivalent 30 | -- to /r/list/#Text for the current User. 31 | /u/#UserId/list/#Text UserListR GET 32 | 33 | /r/!#ResourceId ResourceR GET 34 | /r/!#ResourceId/edit EditResourceR GET POST 35 | /r/list/#Text ResourceListR GET 36 | /r/list/#Text/add/#ResourceId ResourceListAddR POST 37 | /r/list/#Text/del/#ResourceId ResourceListDelR POST 38 | 39 | /admin/edits AllEditsR GET 40 | /e/title/#EditTitleId/accept EditTitleAcceptR POST 41 | /e/title/#EditTitleId/decline EditTitleDeclineR POST 42 | /e/authors/#EditAuthorsId/accept EditAuthorsAcceptR POST 43 | /e/authors/#EditAuthorsId/decline EditAuthorsDeclineR POST 44 | /e/published/#EditPublishedId/accept EditPublishedAcceptR POST 45 | /e/published/#EditPublishedId/decline EditPublishedDeclineR POST 46 | /e/type/#EditTypeId/accept EditTypeAcceptR POST 47 | /e/type/#EditTypeId/decline EditTypeDeclineR POST 48 | /e/addtag/#EditAddTagId/accept EditAddTagAcceptR POST 49 | /e/addtag/#EditAddTagId/decline EditAddTagDeclineR POST 50 | /e/remtag/#EditRemoveTagId/accept EditRemoveTagAcceptR POST 51 | /e/remtag/#EditRemoveTagId/decline EditRemoveTagDeclineR POST 52 | /e/addcol/#EditAddCollectionId/accept EditAddCollectionAcceptR POST 53 | /e/addcol/#EditAddCollectionId/decline EditAddCollectionDeclineR POST 54 | /e/remcol/#EditRemoveCollectionId/accept EditRemoveCollectionAcceptR POST 55 | /e/remcol/#EditRemoveCollectionId/decline EditRemoveCollectionDeclineR POST 56 | 57 | /api/r/exists ApiResourceExists POST 58 | -------------------------------------------------------------------------------- /config/settings.yml: -------------------------------------------------------------------------------- 1 | # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. 2 | # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables 3 | 4 | static-dir: "_env:STATIC_DIR:static" 5 | host: "_env:HOST:*4" # any IPv4 host 6 | port: "_env:PORT:3000" 7 | approot: "_env:APPROOT:http://localhost:3000" 8 | ip-from-header: "_env:IP_FROM_HEADER:false" 9 | oauth-client-secret: "_env:OAUTH_CLIENT_SECRET:" 10 | 11 | # Optional values with the following production defaults. 12 | # In development, they default to the inverse. 13 | # 14 | # development: false 15 | # detailed-logging: false 16 | # should-log-all: false 17 | # reload-templates: false 18 | # mutable-static: false 19 | # skip-combining: false 20 | 21 | database: 22 | database: "_env:SQLITE_DATABASE:dohaskell.sqlite3" 23 | poolsize: "_env:SQLITE_POOLSIZE:10" 24 | 25 | copyright: Insert copyright statement here 26 | #analytics: UA-YOURCODE 27 | -------------------------------------------------------------------------------- /config/sqlite.yml: -------------------------------------------------------------------------------- 1 | Default: &defaults 2 | database: dohaskell.sqlite3 3 | poolsize: 10 4 | 5 | Development: 6 | <<: *defaults 7 | 8 | Testing: 9 | database: dohaskell_test.sqlite3 10 | <<: *defaults 11 | 12 | Staging: 13 | database: dohaskell_staging.sqlite3 14 | poolsize: 100 15 | <<: *defaults 16 | 17 | Production: 18 | database: dohaskell_production.sqlite3 19 | poolsize: 100 20 | <<: *defaults 21 | -------------------------------------------------------------------------------- /deploy/Procfile: -------------------------------------------------------------------------------- 1 | # Free deployment to Heroku. 2 | # 3 | # !! Warning: You must use a 64 bit machine to compile !! 4 | # 5 | # This could mean using a virtual machine. Give your VM as much memory as you can to speed up linking. 6 | # 7 | # Basic Yesod setup: 8 | # 9 | # * Move this file out of the deploy directory and into your root directory 10 | # 11 | # mv deploy/Procfile ./ 12 | # 13 | # * Create an empty package.json 14 | # echo '{ "name": "dohaskell", "version": "0.0.1", "dependencies": {} }' >> package.json 15 | # 16 | # Postgresql Yesod setup: 17 | # 18 | # * add dependencies on the "heroku", "aeson" and "unordered-containers" packages in your cabal file 19 | # 20 | # * add code in Application.hs to use the heroku package and load the connection parameters. 21 | # The below works for Postgresql. 22 | # 23 | # import Data.HashMap.Strict as H 24 | # import Data.Aeson.Types as AT 25 | # #ifndef DEVELOPMENT 26 | # import qualified Web.Heroku 27 | # #endif 28 | # 29 | # 30 | # 31 | # makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App 32 | # makeFoundation conf setLogger = do 33 | # manager <- newManager def 34 | # s <- staticSite 35 | # hconfig <- loadHerokuConfig 36 | # dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf) 37 | # (Database.Persist.Store.loadConfig . combineMappings hconfig) >>= 38 | # Database.Persist.Store.applyEnv 39 | # p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig) 40 | # Database.Persist.Store.runPool dbconf (runMigration migrateAll) p 41 | # return $ App conf setLogger s p manager dbconf 42 | # 43 | # #ifndef DEVELOPMENT 44 | # canonicalizeKey :: (Text, val) -> (Text, val) 45 | # canonicalizeKey ("dbname", val) = ("database", val) 46 | # canonicalizeKey pair = pair 47 | # 48 | # toMapping :: [(Text, Text)] -> AT.Value 49 | # toMapping xs = AT.Object $ M.fromList $ map (\(key, val) -> (key, AT.String val)) xs 50 | # #endif 51 | # 52 | # combineMappings :: AT.Value -> AT.Value -> AT.Value 53 | # combineMappings (AT.Object m1) (AT.Object m2) = AT.Object $ m1 `M.union` m2 54 | # combineMappings _ _ = error "Data.Object is not a Mapping." 55 | # 56 | # loadHerokuConfig :: IO AT.Value 57 | # loadHerokuConfig = do 58 | # #ifdef DEVELOPMENT 59 | # return $ AT.Object M.empty 60 | # #else 61 | # Web.Heroku.dbConnParams >>= return . toMapping . map canonicalizeKey 62 | # #endif 63 | 64 | 65 | 66 | # Heroku setup: 67 | # Find the Heroku guide. Roughly: 68 | # 69 | # * sign up for a heroku account and register your ssh key 70 | # * create a new application on the *cedar* stack 71 | # 72 | # * make your Yesod project the git repository for that application 73 | # * create a deploy branch 74 | # 75 | # git checkout -b deploy 76 | # 77 | # Repeat these steps to deploy: 78 | # * add your web executable binary (referenced below) to the git repository 79 | # 80 | # git checkout deploy 81 | # git add ./dist/build/dohaskell/dohaskell 82 | # git commit -m deploy 83 | # 84 | # * push to Heroku 85 | # 86 | # git push heroku deploy:master 87 | 88 | 89 | # Heroku configuration that runs your app 90 | web: ./dist/build/dohaskell/dohaskell production -p $PORT 91 | -------------------------------------------------------------------------------- /dohaskell.cabal: -------------------------------------------------------------------------------- 1 | name: dohaskell 2 | synopsis: Tagged Haskell resources index website. 3 | version: 0.0.1.0 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Mitchell Rosen 7 | maintainer: mitchellwrosen@gmail.com 8 | cabal-version: >= 1.8 9 | build-type: Simple 10 | 11 | Flag dev 12 | Description: Turn on development settings, like auto-reload templates. 13 | Default: False 14 | 15 | Flag library-only 16 | Description: Build for use with "yesod devel" 17 | Default: False 18 | 19 | library 20 | hs-source-dirs: src 21 | exposed-modules: Application 22 | Database.Persist.Class.Extra 23 | Data.Tree.Extra 24 | Import 25 | Foundation 26 | Handler.About 27 | Handler.Api.Resource 28 | Handler.Browse 29 | Handler.Common 30 | Handler.EditResourceRequest 31 | Handler.Feed 32 | Handler.Resource 33 | Handler.ReqEditsHub 34 | Handler.Submit 35 | Handler.User 36 | Handler.Utils 37 | Model 38 | Model.Author 39 | Model.Browse 40 | Model.Collection 41 | Model.Feed 42 | Model.Feed.Internal 43 | Model.List 44 | Model.Resource 45 | Model.Resource.Internal 46 | Model.ResourceEdit 47 | Model.Tag 48 | Model.User 49 | Model.Utils 50 | Settings 51 | Settings.StaticFiles 52 | View.Browse 53 | View.Feed 54 | View.Navbar 55 | View.Resource 56 | View.User 57 | Yesod.Form.Types.Extra 58 | 59 | if flag(dev) || flag(library-only) 60 | cpp-options: -DDEVELOPMENT 61 | ghc-options: -Wall -fwarn-tabs -O0 62 | else 63 | ghc-options: -Wall -fwarn-tabs -O2 64 | 65 | extensions: CPP 66 | DeriveDataTypeable 67 | EmptyDataDecls 68 | FlexibleContexts 69 | FlexibleInstances 70 | GADTs 71 | GeneralizedNewtypeDeriving 72 | LambdaCase 73 | MultiParamTypeClasses 74 | MultiWayIf 75 | NoImplicitPrelude 76 | NoMonomorphismRestriction 77 | OverloadedStrings 78 | QuasiQuotes 79 | RecordWildCards 80 | ScopedTypeVariables 81 | TemplateHaskell 82 | TypeFamilies 83 | ViewPatterns 84 | 85 | build-depends: base >= 4 && < 5 86 | , aeson 87 | , async 88 | , attoparsec 89 | , blaze-markup 90 | , bytestring 91 | , classy-prelude-yesod 92 | , conduit 93 | , containers 94 | , data-default 95 | , directory 96 | , dlist 97 | , esqueleto 98 | , fast-logger 99 | , file-embed 100 | , feed 101 | , hjsmin 102 | , http-client 103 | , http-conduit 104 | , http-types 105 | , lens 106 | , lifted-base 107 | , monad-control 108 | , monad-logger 109 | , persistent 110 | , persistent-sqlite 111 | , persistent-template 112 | , resourcet 113 | , shakespeare 114 | , split 115 | , template-haskell 116 | , text 117 | , time 118 | , transformers 119 | , wai-extra 120 | , wai-logger 121 | , warp 122 | , wreq 123 | , xml 124 | , yaml 125 | , yesod 126 | , yesod-auth 127 | , yesod-core 128 | , yesod-form 129 | , yesod-markdown 130 | , yesod-static 131 | 132 | executable dohaskell 133 | if flag(library-only) 134 | Buildable: False 135 | 136 | main-is: main.hs 137 | hs-source-dirs: app 138 | build-depends: base 139 | , dohaskell 140 | , yesod 141 | 142 | ghc-options: -threaded -O2 -rtsopts -with-rtsopts=-N 143 | 144 | test-suite test 145 | type: exitcode-stdio-1.0 146 | main-is: main.hs 147 | hs-source-dirs: tests 148 | ghc-options: -Wall 149 | 150 | build-depends: base 151 | , dohaskell 152 | , yesod-test 153 | , yesod-core 154 | , yesod 155 | , persistent 156 | , persistent-sqlite 157 | , resourcet 158 | , monad-logger 159 | , transformers 160 | , hspec 161 | -------------------------------------------------------------------------------- /messages/en.msg: -------------------------------------------------------------------------------- 1 | Hello: Hello 2 | -------------------------------------------------------------------------------- /migrations/1.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE "author"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,CONSTRAINT "unique_author" UNIQUE ("name")); 2 | INSERT INTO "author"("name") SELECT DISTINCT "author" FROM "resource" WHERE "author" IS NOT NULL; 3 | CREATE TABLE "res_author"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","auth_id" INTEGER NOT NULL REFERENCES "author","ord" INTEGER NOT NULL,CONSTRAINT "unique_res_author" UNIQUE ("res_id","auth_id")); 4 | INSERT INTO "res_author"("res_id","auth_id","ord") SELECT r.id,a.id,0 FROM "resource" AS r INNER JOIN "author" AS a ON r.author = a.name; 5 | DROP TABLE "edit_author"; 6 | CREATE TABLE "edit_authors"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","authors" VARCHAR NOT NULL,CONSTRAINT "unique_edit_authors" UNIQUE ("res_id","authors")); 7 | CREATE TEMP TABLE "resource_backup"("id" INTEGER PRIMARY KEY,"title" VARCHAR NOT NULL,"url" VARCHAR NOT NULL,"published" INTEGER NULL,"type" VARCHAR NOT NULL,"user_id" INTEGER NOT NULL REFERENCES "user","posted" TIMESTAMP NOT NULL,CONSTRAINT "unique_resource_url" UNIQUE ("url")); 8 | INSERT INTO "resource_backup"("id","title","url","published","type","user_id","posted") SELECT "id","title","url","published","type","user_id","posted" FROM "resource"; 9 | DROP TABLE "resource"; 10 | CREATE TABLE "resource"("id" INTEGER PRIMARY KEY,"title" VARCHAR NOT NULL,"url" VARCHAR NOT NULL,"published" INTEGER NULL,"type" VARCHAR NOT NULL,"user_id" INTEGER NOT NULL REFERENCES "user","posted" TIMESTAMP NOT NULL,CONSTRAINT "unique_resource_url" UNIQUE ("url")); 11 | INSERT INTO "resource" SELECT "id","title","url","published","type","user_id","posted" FROM "resource_backup"; 12 | DROP TABLE "resource_backup"; 13 | CREATE TEMP TABLE "tag_backup"("id" INTEGER PRIMARY KEY,"tag" VARCHAR NOT NULL,CONSTRAINT "unique_tag" UNIQUE ("tag")); 14 | INSERT INTO "tag_backup"("id","tag") SELECT "id","text" FROM "tag"; 15 | DROP TABLE "tag"; 16 | CREATE TABLE "tag"("id" INTEGER PRIMARY KEY,"tag" VARCHAR NOT NULL,CONSTRAINT "unique_tag" UNIQUE ("tag")); 17 | INSERT INTO "tag" SELECT "id","tag" FROM "tag_backup"; 18 | DROP TABLE "tag_backup"; 19 | -------------------------------------------------------------------------------- /migrations/2.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE "feed"("id" INTEGER PRIMARY KEY,"type" VARCHAR NOT NULL,"title" VARCHAR NOT NULL,"url" VARCHAR NOT NULL,"last_modified" BLOB NOT NULL,"etag" BLOB NOT NULL,"contents" BLOB NOT NULL,CONSTRAINT "unique_feed" UNIQUE ("url")); 2 | -------------------------------------------------------------------------------- /migrations/3.sql: -------------------------------------------------------------------------------- 1 | CREATE TEMP TABLE "user_backup"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"display_name" VARCHAR NOT NULL,"is_administrator" BOOLEAN NOT NULL,"created" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_user_name" UNIQUE ("name")); 2 | INSERT INTO "user_backup"("id","name","display_name","is_administrator") SELECT "id","name","display_name","is_administrator" FROM "user"; 3 | DROP TABLE "user"; 4 | CREATE TABLE "user"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"display_name" VARCHAR NOT NULL,"is_administrator" BOOLEAN NOT NULL,"created" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_user_name" UNIQUE ("name")); 5 | INSERT INTO "user" SELECT "id","name","display_name","is_administrator","created" FROM "user_backup"; 6 | DROP TABLE "user_backup"; 7 | CREATE TEMP TABLE "favorite_backup"("id" INTEGER PRIMARY KEY,"user_id" INTEGER NOT NULL REFERENCES "user","res_id" INTEGER NOT NULL REFERENCES "resource","timestamp" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_favorite" UNIQUE ("user_id","res_id")); 8 | INSERT INTO "favorite_backup"("id","user_id","res_id") SELECT "id","user_id","res_id" FROM "favorite"; 9 | DROP TABLE "favorite"; 10 | CREATE TABLE "favorite"("id" INTEGER PRIMARY KEY,"user_id" INTEGER NOT NULL REFERENCES "user","res_id" INTEGER NOT NULL REFERENCES "resource","timestamp" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_favorite" UNIQUE ("user_id","res_id")); 11 | INSERT INTO "favorite" SELECT "id","user_id","res_id","timestamp" FROM "favorite_backup"; 12 | DROP TABLE "favorite_backup"; 13 | CREATE TEMP TABLE "grokked_backup"("id" INTEGER PRIMARY KEY,"user_id" INTEGER NOT NULL REFERENCES "user","res_id" INTEGER NOT NULL REFERENCES "resource","timestamp" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_grokked" UNIQUE ("user_id","res_id")); 14 | INSERT INTO "grokked_backup"("id","user_id","res_id") SELECT "id","user_id","res_id" FROM "grokked"; 15 | DROP TABLE "grokked"; 16 | CREATE TABLE "grokked"("id" INTEGER PRIMARY KEY,"user_id" INTEGER NOT NULL REFERENCES "user","res_id" INTEGER NOT NULL REFERENCES "resource","timestamp" TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP,CONSTRAINT "unique_grokked" UNIQUE ("user_id","res_id")); 17 | INSERT INTO "grokked" SELECT "id","user_id","res_id","timestamp" FROM "grokked_backup"; 18 | DROP TABLE "grokked_backup"; 19 | -------------------------------------------------------------------------------- /migrations/4.sql: -------------------------------------------------------------------------------- 1 | CREATE TEMP TABLE "tag_backup"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,CONSTRAINT "unique_tag" UNIQUE ("name")); 2 | INSERT INTO "tag_backup"("id","name") SELECT "id","tag" FROM "tag"; 3 | DROP TABLE "tag"; 4 | CREATE TABLE "tag"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,CONSTRAINT "unique_tag" UNIQUE ("name")); 5 | INSERT INTO "tag" SELECT "id","name" FROM "tag_backup"; 6 | DROP TABLE "tag_backup"; 7 | CREATE TABLE "collection"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,CONSTRAINT "unique_collection" UNIQUE ("name")); 8 | CREATE TABLE "res_collection"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","col_id" INTEGER NOT NULL REFERENCES "collection",CONSTRAINT "unique_res_collection" UNIQUE ("res_id","col_id")); 9 | CREATE TABLE "edit_add_collection"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","name" VARCHAR NOT NULL,CONSTRAINT "unique_edit_add_collection" UNIQUE ("res_id","name")); 10 | CREATE TABLE "edit_remove_collection"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","name" VARCHAR NOT NULL,CONSTRAINT "unique_edit_remove_collection" UNIQUE ("res_id","name")); 11 | -------------------------------------------------------------------------------- /migrations/5.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE "list"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,CONSTRAINT "unique_list" UNIQUE ("name")); 2 | CREATE TABLE "list_item"("id" INTEGER PRIMARY KEY,"user_id" INTEGER NOT NULL REFERENCES "user","list_id" INTEGER NOT NULL REFERENCES "list","res_id" INTEGER NOT NULL REFERENCES "resource","timestamp" TIMESTAMP NOT NULL,CONSTRAINT "unique_list_item" UNIQUE ("user_id","list_id","res_id")); 3 | INSERT INTO "list"("id", "name") VALUES (1, "grokked"); 4 | INSERT INTO "list"("id", "name") VALUES (2, "favorites"); 5 | INSERT INTO "list_item"("user_id", "list_id", "res_id", "timestamp") SELECT user_id, 1, res_id, timestamp FROM "grokked"; 6 | INSERT INTO "list_item"("user_id", "list_id", "res_id", "timestamp") SELECT user_id, 2, res_id, timestamp FROM "favorite"; 7 | DROP TABLE "grokked"; 8 | DROP TABLE "favorite"; 9 | CREATE TABLE "comment"("id" INTEGER PRIMARY KEY,"res_id" INTEGER NOT NULL REFERENCES "resource","parent_id" INTEGER NULL REFERENCES "comment","user_id" INTEGER NOT NULL REFERENCES "user","body" VARCHAR NOT NULL,"timestamp" TIMESTAMP NOT NULL); 10 | -------------------------------------------------------------------------------- /migrations/6.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE "comment"; 2 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Application 3 | ( getApplicationDev 4 | , appMain 5 | , develMain 6 | , makeFoundation 7 | -- * for DevelMain 8 | , getApplicationRepl 9 | , shutdownApp 10 | -- * for GHCI 11 | , handler 12 | , db 13 | ) where 14 | 15 | import Control.Monad.Logger (liftLoc, runLoggingT) 16 | import Database.Persist.Sqlite (createSqlitePool, runSqlPool, 17 | sqlDatabase, sqlPoolSize) 18 | import Import 19 | import Language.Haskell.TH.Syntax (qLocation) 20 | import Network.Wai.Handler.Warp (Settings, defaultSettings, 21 | defaultShouldDisplayException, 22 | runSettings, setHost, 23 | setOnException, setPort, getPort) 24 | import Network.Wai.Middleware.RequestLogger (Destination (Logger), 25 | IPAddrSource (..), 26 | OutputFormat (..), destination, 27 | mkRequestLogger, outputFormat) 28 | import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, 29 | toLogStr) 30 | 31 | -- Import all relevant handler modules here. 32 | -- Don't forget to add new modules to your cabal file! 33 | import Handler.About 34 | import Handler.Api.Resource 35 | import Handler.Browse 36 | import Handler.Common 37 | import Handler.EditResourceRequest 38 | import Handler.Feed 39 | import Handler.ReqEditsHub 40 | import Handler.Resource 41 | import Handler.Submit 42 | import Handler.User 43 | 44 | import View.Navbar (navbarWidget) 45 | 46 | mkYesodDispatch "App" resourcesApp 47 | 48 | makeFoundation :: AppSettings -> IO App 49 | makeFoundation appSettings = do 50 | appHttpManager <- newManager 51 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 52 | appStatic <- 53 | (if appMutableStatic appSettings then staticDevel else static) 54 | (appStaticDir appSettings) 55 | let appNavbar = navbarWidget 56 | 57 | let mkFoundation appConnPool = App {..} 58 | tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" 59 | logFunc = messageLoggerSource tempFoundation appLogger 60 | 61 | pool <- flip runLoggingT logFunc $ createSqlitePool 62 | (sqlDatabase $ appDatabaseConf appSettings) 63 | (sqlPoolSize $ appDatabaseConf appSettings) 64 | 65 | runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc 66 | 67 | return $ mkFoundation pool 68 | 69 | makeApplication :: App -> IO Application 70 | makeApplication foundation = do 71 | logWare <- mkRequestLogger def 72 | { outputFormat = 73 | if appDetailedRequestLogging $ appSettings foundation 74 | then Detailed True 75 | else Apache 76 | (if appIpFromHeader $ appSettings foundation 77 | then FromFallback 78 | else FromSocket) 79 | , destination = Logger $ loggerSet $ appLogger foundation 80 | } 81 | 82 | appPlain <- toWaiAppPlain foundation 83 | return $ logWare $ defaultMiddlewaresNoLogging appPlain 84 | 85 | warpSettings :: App -> Settings 86 | warpSettings foundation = 87 | setPort (appPort $ appSettings foundation) 88 | $ setHost (appHost $ appSettings foundation) 89 | $ setOnException (\_req e -> 90 | when (defaultShouldDisplayException e) $ messageLoggerSource 91 | foundation 92 | (appLogger foundation) 93 | $(qLocation >>= liftLoc) 94 | "yesod" 95 | LevelError 96 | (toLogStr $ "Exception from Warp: " ++ show e)) 97 | defaultSettings 98 | 99 | getApplicationDev :: IO (Settings, Application) 100 | getApplicationDev = do 101 | settings <- getAppSettings 102 | foundation <- makeFoundation settings 103 | wsettings <- getDevSettings $ warpSettings foundation 104 | app <- makeApplication foundation 105 | return (wsettings, app) 106 | 107 | getAppSettings :: IO AppSettings 108 | getAppSettings = loadAppSettings [configSettingsYml] [] useEnv 109 | 110 | develMain :: IO () 111 | develMain = develMainHelper getApplicationDev 112 | 113 | appMain :: IO () 114 | appMain = do 115 | settings <- loadAppSettingsArgs 116 | [configSettingsYmlValue] 117 | 118 | useEnv 119 | 120 | foundation <- makeFoundation settings 121 | 122 | app <- makeApplication foundation 123 | 124 | runSettings (warpSettings foundation) app 125 | 126 | -------------------------------------------------------------- 127 | -- Functions for DevelMain.hs (a way to run the app from GHCi) 128 | -------------------------------------------------------------- 129 | 130 | getApplicationRepl :: IO (Int, App, Application) 131 | getApplicationRepl = do 132 | settings <- getAppSettings 133 | foundation <- makeFoundation settings 134 | wsettings <- getDevSettings $ warpSettings foundation 135 | app1 <- makeApplication foundation 136 | return (getPort wsettings, foundation, app1) 137 | 138 | shutdownApp :: App -> IO () 139 | shutdownApp _ = return () 140 | 141 | --------------------------------------------- 142 | -- Functions for use in development with GHCi 143 | --------------------------------------------- 144 | 145 | -- | Run a handler 146 | handler :: Handler a -> IO a 147 | handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h 148 | 149 | -- | Run DB queries 150 | db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a 151 | db = handler . runDB 152 | -------------------------------------------------------------------------------- /src/Data/Tree/Extra.hs: -------------------------------------------------------------------------------- 1 | module Data.Tree.Extra where 2 | 3 | import Prelude ((.), Ordering, map) 4 | 5 | import Data.List (sortBy) 6 | import Data.Tree (Forest, Tree(..)) 7 | 8 | sortTreeBy :: (Tree a -> Tree a -> Ordering) -> Tree a -> Tree a 9 | sortTreeBy f (Node x xs) = Node x (sortForestBy f xs) 10 | 11 | sortForestBy :: (Tree a -> Tree a -> Ordering) -> Forest a -> Forest a 12 | sortForestBy f = sortBy f . map (sortTreeBy f) 13 | 14 | singleton :: a -> Tree a 15 | singleton x = Node x [] 16 | -------------------------------------------------------------------------------- /src/Database/Persist/Class/Extra.hs: -------------------------------------------------------------------------------- 1 | module Database.Persist.Class.Extra where 2 | 3 | import Control.Monad.IO.Class (MonadIO) 4 | import Control.Monad.Trans.Reader (ReaderT) 5 | import Database.Persist.Class 6 | import Database.Persist.Types 7 | import Prelude 8 | 9 | -- Like insertBy, but only return the Key if the Entity exists, not the whole Entity 10 | insertBy' :: (MonadIO m, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend) 11 | => val 12 | -> ReaderT backend m (Key val) 13 | insertBy' = fmap (either entityKey id) . insertBy 14 | -------------------------------------------------------------------------------- /src/Foundation.hs: -------------------------------------------------------------------------------- 1 | module Foundation where 2 | 3 | import Import.NoFoundation 4 | 5 | import Database.Persist.Sql (ConnectionPool, runSqlPool) 6 | import Text.Hamlet (hamletFile) 7 | import Text.Jasmine (minifym) 8 | import Yesod.Auth.GoogleEmail2 9 | import Yesod.Core.Types (Logger) 10 | import Yesod.Default.Util (addStaticContentExternal) 11 | 12 | import qualified Yesod.Core.Unsafe as Unsafe 13 | 14 | data App = App 15 | { appSettings :: AppSettings 16 | , appStatic :: Static 17 | , appConnPool :: ConnectionPool 18 | , appHttpManager :: Manager 19 | , appLogger :: Logger 20 | , appNavbar :: WidgetT App IO () 21 | } 22 | 23 | instance HasHttpManager App where 24 | getHttpManager = appHttpManager 25 | 26 | mkYesodData "App" $(parseRoutesFile "config/routes") 27 | 28 | type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) 29 | 30 | instance Yesod App where 31 | approot = ApprootMaster $ appRoot . appSettings 32 | 33 | makeSessionBackend _ = Just <$> defaultClientSessionBackend timeoutMins keyFile 34 | where 35 | timeoutMins = 10080 -- 1 week 36 | keyFile = "config/client_session_key.aes" 37 | 38 | defaultLayout innerWidget = do 39 | mmsg <- getMessage 40 | navbarWidget <- appNavbar <$> getYesod 41 | 42 | pc <- 43 | widgetToPageContent $ do 44 | $(combineStylesheets 'StaticR 45 | [ css_normalize_css 46 | , css_bootstrap_css 47 | ]) 48 | addScriptRemote "http://ajax.googleapis.com/ajax/libs/jquery/1.11.1/jquery.min.js" 49 | $(widgetFile "default-layout") 50 | withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") 51 | 52 | authRoute _ = Just $ AuthR LoginR 53 | 54 | -- Gave up trying to use this function because Foundation can't import 55 | -- anything that imports Import (which is everything). 56 | isAuthorized _ _ = return Authorized 57 | 58 | addStaticContent ext mime content = do 59 | master <- getYesod 60 | let staticDir = appStaticDir $ appSettings master 61 | addStaticContentExternal 62 | minifym 63 | genFileName 64 | staticDir 65 | (StaticR . flip StaticRoute []) 66 | ext 67 | mime 68 | content 69 | where 70 | genFileName lbs = "autogen-" ++ base64md5 lbs 71 | 72 | shouldLog app _source level = 73 | appShouldLogAll (appSettings app) 74 | || level == LevelWarn 75 | || level == LevelError 76 | 77 | makeLogger = return . appLogger 78 | 79 | requiresAuthorization :: Handler AuthResult 80 | requiresAuthorization = maybe AuthenticationRequired (const Authorized) <$> maybeAuthId 81 | 82 | -- How to run database actions. 83 | instance YesodPersist App where 84 | type YesodPersistBackend App = SqlBackend 85 | runDB action = getYesod >>= runSqlPool action . appConnPool 86 | 87 | instance YesodPersistRunner App where 88 | getDBRunner = defaultGetDBRunner appConnPool 89 | 90 | instance YesodAuth App where 91 | type AuthId App = UserId 92 | 93 | loginDest _ = HomeR 94 | logoutDest _ = HomeR 95 | redirectToReferer _ = True 96 | 97 | authenticate creds = 98 | case credsPlugin creds of 99 | "googleemail2" -> 100 | runDB $ 101 | getBy (UniqueUserName $ credsIdent creds) >>= \case 102 | Just (Entity uid _) -> pure (Authenticated uid) 103 | Nothing -> 104 | liftIO getCurrentTime 105 | >>= insert . User (credsIdent creds) "anonymous" False 106 | >>= pure . Authenticated 107 | 108 | authPlugins app = 109 | [ authGoogleEmail 110 | "841602685019-ekt6mj8rcr10lvhgvbso3e21qviirq5b.apps.googleusercontent.com" 111 | (appOauthClientSecret (appSettings app)) 112 | ] 113 | 114 | authHttpManager = appHttpManager 115 | 116 | instance YesodAuthPersist App 117 | 118 | instance RenderMessage App FormMessage where 119 | renderMessage _ _ = defaultFormMessage 120 | 121 | unsafeHandler :: App -> Handler a -> IO a 122 | unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 123 | -------------------------------------------------------------------------------- /src/Handler/About.hs: -------------------------------------------------------------------------------- 1 | module Handler.About where 2 | 3 | import Import 4 | 5 | getAboutR :: Handler Html 6 | getAboutR = do 7 | muid <- maybeAuthId 8 | defaultLayout $ do 9 | setTitle "dohaskell | about" 10 | $(widgetFile "about") 11 | -------------------------------------------------------------------------------- /src/Handler/Api/Resource.hs: -------------------------------------------------------------------------------- 1 | module Handler.Api.Resource where 2 | 3 | import Import 4 | 5 | postApiResourceExists :: Handler TypedContent 6 | postApiResourceExists = return $ toTypedContent $ 7 | object 8 | [ "success" .= True 9 | , "result" .= True 10 | ] 11 | -------------------------------------------------------------------------------- /src/Handler/Browse.hs: -------------------------------------------------------------------------------- 1 | -- FIXME: lots of code duplication in this module 2 | 3 | module Handler.Browse where 4 | 5 | import Import 6 | 7 | import Handler.Utils 8 | import Model.Author 9 | import Model.Browse 10 | import Model.Collection 11 | import Model.Resource 12 | import Model.Tag 13 | import Model.User 14 | import Model.Utils 15 | import View.Browse 16 | 17 | import Database.Esqueleto (asc, desc) 18 | import Data.Aeson (Value(..)) 19 | import Text.Blaze (ToMarkup) 20 | import Text.Hamlet (hamletFile) 21 | 22 | import qualified Data.Map as M 23 | import qualified Data.Text as T 24 | 25 | -- | Look up GET param for sorting, default to alphabetical. 26 | lookupSortByParam :: Handler SortBy 27 | lookupSortByParam = lookupGetParam "sort" >>= \case 28 | Just "count-up" -> return SortByCountUp 29 | Just "count-down" -> return SortByCountDown 30 | Just "year-up" -> return SortByYearUp 31 | Just "year-down" -> return SortByYearDown 32 | _ -> return SortByAZ 33 | 34 | -- | Look up GET param for sorting resources, default to alphabetical. 35 | lookupSortResByParam :: Handler SortBy 36 | lookupSortResByParam = lookupGetParam "sort-res" >>= \case 37 | Just "year-up" -> return SortByYearUp 38 | Just "year-down" -> return SortByYearDown 39 | Just "recently-added" -> return SortByRecentlyAdded 40 | _ -> return SortByAZ 41 | 42 | -- | Look up GET param for page; given the page size, return page num, limit, 43 | -- and offset. 44 | lookupPageParam :: Int64 -> Handler (Int64, Int64, Int64) 45 | lookupPageParam page_size = do 46 | page <- fromMaybe 1 . (\p -> p >>= readMay) <$> lookupGetParam "page" 47 | let lim = page_size + 1 48 | off = (page-1) * page_size 49 | pure (page, lim, off) 50 | 51 | resourceOrder :: SortBy -> Entity Resource -> Entity Resource -> Ordering 52 | resourceOrder = \case 53 | SortByYearUp -> orderResourceYearUp 54 | SortByYearDown -> orderResourceYearDown 55 | SortByRecentlyAdded -> orderResourceRecentlyAdded 56 | _ -> orderAlphabeticIgnoreCase (resourceTitle . entityVal) 57 | where 58 | orderResourceYearUp :: Entity Resource -> Entity Resource -> Ordering 59 | orderResourceYearUp (Entity _ x) (Entity _ y) = 60 | compareEarliest (resourcePublished x) (resourcePublished y) <> 61 | orderAlphabeticIgnoreCase resourceTitle x y 62 | where 63 | compareEarliest :: Maybe Int -> Maybe Int -> Ordering 64 | compareEarliest (Just n) (Just m) = compare n m 65 | compareEarliest Nothing (Just _) = GT -- Nothing means no year, so put it at the bottom 66 | compareEarliest (Just _) Nothing = LT 67 | compareEarliest _ _ = EQ 68 | 69 | orderResourceYearDown :: Entity Resource -> Entity Resource -> Ordering 70 | orderResourceYearDown (Entity _ x) (Entity _ y) = 71 | compareLatest (resourcePublished x) (resourcePublished y) <> orderAlphabeticIgnoreCase resourceTitle x y 72 | where 73 | compareLatest :: Maybe Int -> Maybe Int -> Ordering 74 | compareLatest (Just n) (Just m) = compare m n 75 | compareLatest Nothing (Just _) = GT -- Nothing means no year, so put it at the bottom 76 | compareLatest (Just _) Nothing = LT 77 | compareLatest _ _ = EQ 78 | 79 | orderResourceRecentlyAdded :: Entity Resource -> Entity Resource -> Ordering 80 | orderResourceRecentlyAdded (Entity uidx _) (Entity uidy _) = 81 | compare uidy uidx -- Ids as substitutes for submission dates 82 | 83 | vshow :: Show a => a -> Value 84 | vshow = String . T.pack . show 85 | 86 | -------------------------------------------------------------------------------- 87 | 88 | getHomeR :: Handler Html 89 | getHomeR = browseTagsHandler "dohaskell: tagged Haskell learning resources" 90 | 91 | getAuthorR, getCollectionR, getTagR :: Text -> Handler Html 92 | getAuthorR text = getResources (fetchResourcesByAuthorDB text) ("dohaskell | by " <> text) 93 | getCollectionR text = getResources (fetchResourcesInCollectionDB text) ("dohaskell | in " <> text) 94 | getTagR text = getResources (fetchResourcesWithTagDB text) ("dohaskell | " <> text) 95 | 96 | getTypeR :: Text -> Handler Html 97 | getTypeR text = case shortReadResourceTypePlural text of 98 | Nothing -> notFound 99 | Just typ -> getResources (fetchResourcesWithTypeDB typ) ("dohaskell | the " <> text) 100 | 101 | -- | Abstract getAuthorR, getCollectionR, getTagR, and getTypeR. Assumes the 102 | -- resources grabbed from the database are unsorted. 103 | getResources 104 | :: ToMarkup markup 105 | => (Int64 -> Int64 -> YesodDB App [Entity Resource]) 106 | -> markup 107 | -> Handler Html 108 | getResources get_resources title = do 109 | sort_res_by <- lookupSortResByParam 110 | 111 | let page_size = 10 112 | 113 | (page, lim, off) <- lookupPageParam page_size 114 | unsorted_resources <- runDB (get_resources lim off) 115 | 116 | let mprev = if page > 1 117 | then Just (page-1) 118 | else Nothing 119 | 120 | mnext = if length unsorted_resources > page_size 121 | then Just (page+1) 122 | else Nothing 123 | 124 | resources = sortBy (resourceOrder sort_res_by) (take page_size unsorted_resources) 125 | 126 | is_embed <- isJust <$> lookupGetParam "embed" 127 | 128 | if is_embed 129 | then do 130 | pc <- widgetToPageContent $ do 131 | setTitle (toHtml title) 132 | resourceListWidget resources 133 | pageWidgetEmbed mprev mnext 134 | withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") 135 | else defaultLayout $ do 136 | setTitle (toHtml title) 137 | sortResBarWidget sort_res_by 138 | resourceListWidget resources 139 | pageWidget mprev mnext 140 | 141 | getBrowseAuthorsR :: Handler Html 142 | getBrowseAuthorsR = do 143 | muid <- maybeAuthId 144 | (unsorted_authors, year_ranges, total_counts, mgrokked_counts) <- runDB $ (,,,) 145 | <$> fetchAllAuthorsDB 146 | <*> fetchAuthorYearRangesDB 147 | <*> fetchAuthorResourceCountsDB 148 | <*> maybe (return Nothing) (fmap Just . fetchGrokkedCountsByAuthorDB) muid 149 | 150 | sort_by <- lookupSortByParam 151 | sort_res_by <- lookupSortResByParam 152 | let order_func = case sort_by of 153 | SortByAZ -> orderAlphabeticIgnoreCase (authorName . entityVal) 154 | SortByCountUp -> orderCountUp (authorName . entityVal) entityKey total_counts 155 | SortByCountDown -> orderCountDown (authorName . entityVal) entityKey total_counts 156 | SortByYearUp -> orderYearUp (authorName . entityVal) entityKey year_ranges 157 | SortByYearDown -> orderYearDown (authorName . entityVal) entityKey year_ranges 158 | SortByRecentlyAdded -> orderAlphabeticIgnoreCase (authorName . entityVal) 159 | entities = sortBy order_func unsorted_authors 160 | get_maps_key = entityKey 161 | get_permalink = AuthorR . authorName . entityVal 162 | show_entity = authorName . entityVal 163 | path_piece = String "/author/" 164 | sort_res_by_text = vshow sort_res_by 165 | 166 | defaultLayout $ do 167 | setTitle "dohaskell | browse authors" 168 | browseBarWidget BrowseByAuthorLink 169 | sortBarWidget "authors" sort_by 170 | sortResBarWidget sort_res_by 171 | $(widgetFile "browse") 172 | 173 | getBrowseCollectionsR :: Handler Html 174 | getBrowseCollectionsR = do 175 | muid <- maybeAuthId 176 | (unsorted_collections, year_ranges, total_counts, mgrokked_counts) <- runDB $ (,,,) 177 | <$> fetchAllCollectionsDB 178 | <*> fetchCollectionYearRangesDB 179 | <*> fetchCollectionResourceCountsDB 180 | <*> maybe (return Nothing) (fmap Just . fetchGrokkedCountsByCollectionDB) muid 181 | 182 | sort_by <- lookupSortByParam 183 | sort_res_by <- lookupSortResByParam 184 | let order_func = case sort_by of 185 | SortByAZ -> orderAlphabeticIgnoreCase (collectionName . entityVal) 186 | SortByCountUp -> orderCountUp (collectionName . entityVal) entityKey total_counts 187 | SortByCountDown -> orderCountDown (collectionName . entityVal) entityKey total_counts 188 | SortByYearUp -> orderYearUp (collectionName . entityVal) entityKey year_ranges 189 | SortByYearDown -> orderYearDown (collectionName . entityVal) entityKey year_ranges 190 | SortByRecentlyAdded -> orderAlphabeticIgnoreCase (collectionName . entityVal) 191 | entities = sortBy order_func unsorted_collections 192 | get_maps_key = entityKey 193 | get_permalink = CollectionR . collectionName . entityVal 194 | show_entity = collectionName . entityVal 195 | path_piece = String "/collection/" 196 | sort_res_by_text = vshow sort_res_by 197 | 198 | defaultLayout $ do 199 | setTitle "dohaskell | browse collections" 200 | browseBarWidget BrowseByCollectionLink 201 | sortBarWidget "collections" sort_by 202 | sortResBarWidget sort_res_by 203 | $(widgetFile "browse") 204 | 205 | getBrowseResourcesR :: Handler Html 206 | getBrowseResourcesR = do 207 | let page_size = 100 208 | 209 | (page, lim, off) <- lookupPageParam page_size 210 | 211 | sort_res_by <- lookupSortResByParam 212 | let order = case sort_res_by of 213 | SortByRecentlyAdded -> desc 214 | _ -> asc 215 | 216 | unsorted_resources <- runDB (fetchAllResourcesDB order lim off) 217 | 218 | let mprev = if page > 1 219 | then Just (page-1) 220 | else Nothing 221 | 222 | mnext = if length unsorted_resources > page_size 223 | then Just (page+1) 224 | else Nothing 225 | 226 | resources = sortBy (resourceOrder sort_res_by) (take page_size unsorted_resources) 227 | 228 | 229 | defaultLayout $ do 230 | setTitle "dohaskell | browse resources" 231 | browseBarWidget BrowseByResourceLink 232 | sortResBarWidget sort_res_by 233 | resourceListWidget resources 234 | pageWidget mprev mnext 235 | 236 | getBrowseTagsR :: Handler Html 237 | getBrowseTagsR = browseTagsHandler "dohaskell | browse tags" 238 | 239 | browseTagsHandler :: Html -> Handler Html 240 | browseTagsHandler title = do 241 | muid <- maybeAuthId 242 | (unsorted_tags, year_ranges, total_counts, mgrokked_counts) <- runDB $ (,,,) 243 | <$> fetchAllTagsDB 244 | <*> fetchTagYearRangesDB 245 | <*> fetchTagCountsDB 246 | <*> maybe (return Nothing) (fmap Just . fetchGrokkedCountsByTagDB) muid 247 | 248 | sort_by <- lookupSortByParam 249 | sort_res_by <- lookupSortResByParam 250 | let order_func = case sort_by of 251 | SortByAZ -> orderAlphabeticIgnoreCase (tagName . entityVal) 252 | SortByCountUp -> orderCountUp (tagName . entityVal) entityKey total_counts 253 | SortByCountDown -> orderCountDown (tagName . entityVal) entityKey total_counts 254 | SortByYearUp -> orderYearUp (tagName . entityVal) entityKey year_ranges 255 | SortByYearDown -> orderYearDown (tagName . entityVal) entityKey year_ranges 256 | SortByRecentlyAdded -> orderAlphabeticIgnoreCase (tagName . entityVal) 257 | entities = sortBy order_func unsorted_tags 258 | get_maps_key = entityKey 259 | get_permalink = TagR . tagName . entityVal 260 | show_entity = tagName . entityVal 261 | path_piece = String "/tag/" 262 | sort_res_by_text = vshow sort_res_by 263 | 264 | defaultLayout $ do 265 | setTitle title 266 | browseBarWidget BrowseByTagLink 267 | sortBarWidget "tags" sort_by 268 | sortResBarWidget sort_res_by 269 | $(widgetFile "browse") 270 | 271 | getBrowseTypesR :: Handler Html 272 | getBrowseTypesR = do 273 | muid <- maybeAuthId 274 | (total_counts, year_ranges, mgrokked_counts) <- runDB $ (,,) 275 | <$> fetchResourceTypeCountsDB 276 | <*> fetchResourceTypeYearRangesDB 277 | <*> maybe (return Nothing) (fmap Just . fetchGrokkedCountsByTypeDB) muid 278 | 279 | sort_by <- lookupSortByParam 280 | sort_res_by <- lookupSortResByParam 281 | let order_func = case sort_by of 282 | SortByAZ -> orderAlphabeticIgnoreCase shortDescResourceTypePlural 283 | SortByCountUp -> orderCountUp shortDescResourceTypePlural id total_counts 284 | SortByCountDown -> orderCountDown shortDescResourceTypePlural id total_counts 285 | SortByYearUp -> orderYearUp shortDescResourceTypePlural id year_ranges 286 | SortByYearDown -> orderYearDown shortDescResourceTypePlural id year_ranges 287 | SortByRecentlyAdded -> orderAlphabeticIgnoreCase shortDescResourceTypePlural 288 | entities = sortBy order_func [minBound..maxBound] 289 | get_maps_key = id 290 | get_permalink = TypeR . shortDescResourceTypePlural 291 | show_entity = shortDescResourceTypePlural 292 | path_piece = String "/type/" 293 | sort_res_by_text = vshow sort_res_by 294 | 295 | defaultLayout $ do 296 | setTitle "dohaskell | browse types" 297 | browseBarWidget BrowseByTypeLink 298 | sortBarWidget "types" sort_by 299 | sortResBarWidget sort_res_by 300 | $(widgetFile "browse") 301 | -------------------------------------------------------------------------------- /src/Handler/Common.hs: -------------------------------------------------------------------------------- 1 | -- | Common handler functions. 2 | module Handler.Common where 3 | 4 | import Data.FileEmbed (embedFile) 5 | import Import 6 | 7 | -- These handlers embed files in the executable at compile time to avoid a 8 | -- runtime dependency, and for efficiency. 9 | 10 | getFaviconR :: Handler TypedContent 11 | getFaviconR = return $ TypedContent "image/x-icon" 12 | $ toContent $(embedFile "config/favicon.ico") 13 | 14 | getRobotsR :: Handler TypedContent 15 | getRobotsR = return $ TypedContent typePlain 16 | $ toContent $(embedFile "config/robots.txt") 17 | -------------------------------------------------------------------------------- /src/Handler/EditResourceRequest.hs: -------------------------------------------------------------------------------- 1 | module Handler.EditResourceRequest where 2 | 3 | import Import 4 | 5 | import Database.Persist.Class.Extra (insertBy') 6 | import Handler.Utils (denyPermissionIfDoesntHaveAuthorityOver) 7 | import Model.Resource (updateResourceAuthorsDB) 8 | 9 | import Database.Esqueleto 10 | import qualified Database.Persist as P 11 | 12 | 13 | -- Adding a title/type is the same - they're both required fields. 14 | 15 | postEditTitleAcceptR :: EditTitleId -> Handler Html 16 | postEditTitleAcceptR eid = editRes editTitleResId sqlCode eid 17 | where 18 | sqlCode (EditTitle resId title) = updateResField resId ResourceTitle title 19 | 20 | postEditTypeAcceptR :: EditTypeId -> Handler Html 21 | postEditTypeAcceptR eid = editRes editTypeResId sqlCode eid 22 | where 23 | sqlCode (EditType resId typ) = updateResField resId ResourceType typ 24 | 25 | postEditAuthorsAcceptR :: EditAuthorsId -> Handler Html 26 | postEditAuthorsAcceptR eid = editRes editAuthorsResId sqlCode eid 27 | where 28 | sqlCode (EditAuthors res_id author_names) = updateResourceAuthorsDB res_id (map Author author_names) 29 | 30 | postEditAddTagAcceptR :: EditAddTagId -> Handler Html 31 | postEditAddTagAcceptR eid = editRes editAddTagResId sqlCode eid 32 | where 33 | sqlCode (EditAddTag resId text) = insertBy' (Tag text) >>= void . insertUnique . ResourceTag resId 34 | 35 | postEditRemoveTagAcceptR :: EditRemoveTagId -> Handler Html 36 | postEditRemoveTagAcceptR eid = editRes editRemoveTagResId sqlCode eid 37 | where 38 | sqlCode (EditRemoveTag resId text) = do 39 | getBy (UniqueTag text) >>= \case 40 | Nothing -> return () 41 | Just (Entity tagId _) -> 42 | deleteOneToMany 43 | (UniqueResourceTag resId tagId) 44 | ResourceTagTagId 45 | tagId 46 | 47 | -- TODO: Share code with add/remove tag, as above. 48 | postEditAddCollectionAcceptR :: EditAddCollectionId -> Handler Html 49 | postEditAddCollectionAcceptR eid = editRes editAddCollectionResId sqlCode eid 50 | where 51 | sqlCode (EditAddCollection resId text) = insertBy' (Collection text) >>= void . insertUnique . ResCollection resId 52 | 53 | postEditRemoveCollectionAcceptR :: EditRemoveCollectionId -> Handler Html 54 | postEditRemoveCollectionAcceptR eid = editRes editRemoveCollectionResId sqlCode eid 55 | where 56 | sqlCode (EditRemoveCollection resId text) = do 57 | getBy (UniqueCollection text) >>= \case 58 | Nothing -> return () 59 | Just (Entity colId _) -> 60 | deleteOneToMany 61 | (UniqueResCollection resId colId) 62 | ResCollectionColId 63 | colId 64 | 65 | -- Delete one of many entities, and delete the entity it references by its 66 | -- id if it happened to be the only one in the one-to-many relation. 67 | deleteOneToMany uniqueEntity idField idVal = do 68 | deleteBy uniqueEntity 69 | n <- P.count [idField P.==. idVal] 70 | when (n == 0) $ 71 | deleteKey idVal 72 | 73 | postEditPublishedAcceptR :: EditPublishedId -> Handler Html 74 | postEditPublishedAcceptR eid = editRes editPublishedResId sqlCode eid 75 | where 76 | sqlCode (EditPublished resId published) = updateResField resId ResourcePublished published 77 | 78 | postEditAddCollectionDeclineR :: EditAddCollectionId -> Handler Html 79 | postEditAddTagDeclineR :: EditAddTagId -> Handler Html 80 | postEditAuthorsDeclineR :: EditAuthorsId -> Handler Html 81 | postEditPublishedDeclineR :: EditPublishedId -> Handler Html 82 | postEditRemoveTagDeclineR :: EditRemoveTagId -> Handler Html 83 | postEditRemoveCollectionDeclineR :: EditRemoveCollectionId -> Handler Html 84 | postEditTitleDeclineR :: EditTitleId -> Handler Html 85 | postEditTypeDeclineR :: EditTypeId -> Handler Html 86 | 87 | postEditAddCollectionDeclineR = declineEditRes editAddCollectionResId 88 | postEditAddTagDeclineR = declineEditRes editAddTagResId 89 | postEditAuthorsDeclineR = declineEditRes editAuthorsResId 90 | postEditPublishedDeclineR = declineEditRes editPublishedResId 91 | postEditRemoveCollectionDeclineR = declineEditRes editRemoveCollectionResId 92 | postEditRemoveTagDeclineR = declineEditRes editRemoveTagResId 93 | postEditTitleDeclineR = declineEditRes editTitleResId 94 | postEditTypeDeclineR = declineEditRes editTypeResId 95 | 96 | declineEditRes :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) 97 | => (val -> ResourceId) 98 | -> Key val 99 | -> Handler a 100 | declineEditRes = flip editRes (\_ -> return ()) 101 | 102 | -- Utility method shared by resource edit functions. Performs boiler 103 | -- plate code such as 404 on invalid edit id, resource id, and deny permission 104 | -- if necessary. Runs arbitrary SQL, which is not responsible for deleting the 105 | -- edit. 106 | 107 | editRes :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) 108 | => (val -> ResourceId) -- ^ ResourceId accessor 109 | -> (val -> YesodDB App ()) -- ^ Arbitrary SQL code to run, given val. 110 | -> Key val 111 | -> Handler a 112 | editRes getResourceFunc sqlCode eid = do 113 | (edit, res) <- runDB $ do 114 | edit <- get404 eid 115 | res <- get404 $ getResourceFunc edit 116 | return (edit, res) 117 | 118 | -- Admins and the user himself may accept an edit. 119 | denyPermissionIfDoesntHaveAuthorityOver $ resourceUserId res 120 | 121 | runDB $ do 122 | sqlCode edit 123 | deleteKey eid 124 | redirectUltDest HomeR 125 | 126 | updateResField resId field value = do 127 | update $ \r -> do 128 | set r [ field =. val value ] 129 | where_ (r^.ResourceId ==. val resId) 130 | -------------------------------------------------------------------------------- /src/Handler/Feed.hs: -------------------------------------------------------------------------------- 1 | module Handler.Feed where 2 | 3 | import Import 4 | 5 | import Model.Feed 6 | import View.Feed 7 | 8 | import Control.Concurrent.Async (race) 9 | import Control.Lens 10 | import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) 11 | import qualified Data.ByteString as BS 12 | import qualified Data.ByteString.Lazy as BSL 13 | import qualified Data.Text as T 14 | import qualified Network.Wreq as Wreq 15 | import qualified Text.Atom.Feed as Atom 16 | import qualified Text.Atom.Feed.Import as Atom 17 | import Text.RSS.Import (elementToRSS) 18 | import Text.RSS.Syntax (rssChannel, rssTitle) 19 | import qualified Text.XML.Light as XML 20 | 21 | feedFailure :: Html -> Handler Html 22 | feedFailure msg = setMessage msg >> redirect FeedsR 23 | 24 | timeout :: Int 25 | timeout = 10 26 | 27 | -- | Time an IO action out after n seconds. Nothing means timeout. 28 | timed :: Int -> IO a -> IO (Maybe a) 29 | timed n = fmap (either (const Nothing) Just) . race (threadDelay $ n * 1000000) 30 | 31 | getFeedR :: Handler Html 32 | getFeedR = runMaybeT lookupParams >>= \case 33 | Nothing -> feedFailure "Missing parameter 'type' or 'url', or unknown 'type'." 34 | Just (Atom, url) -> fetchAtomFeed url 35 | Just (RSS2, url) -> fetchRssFeed url 36 | where 37 | lookupParams :: MaybeT Handler (FeedType, Text) 38 | lookupParams = (,) <$> MaybeT lookupTypeParam <*> MaybeT lookupUrlParam 39 | 40 | lookupTypeParam :: Handler (Maybe FeedType) 41 | lookupTypeParam = maybe Nothing readMay <$> lookupGetParam "type" 42 | 43 | lookupUrlParam :: Handler (Maybe Text) 44 | lookupUrlParam = lookupGetParam "url" 45 | 46 | fetchRssFeed, fetchAtomFeed :: Text -> Handler Html 47 | fetchRssFeed url = fetchFeed elementToRSS (T.pack . rssTitle . rssChannel) (Feed RSS2) (rssFeedWidget url) url 48 | fetchAtomFeed url = fetchFeed Atom.elementFeed (T.pack . Atom.txtToString . Atom.feedTitle) (Feed Atom) (atomFeedWidget url) url 49 | 50 | fetchFeed :: (XML.Element -> Maybe a) 51 | -> (a -> Text) 52 | -> (Text -> Text -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Feed) 53 | -> (a -> Widget) 54 | -> Text 55 | -> Handler Html 56 | fetchFeed parse_feed make_title make_feed make_widget url = 57 | runDB (getFeed url) >>= \case 58 | Nothing -> fetchFeedWith Wreq.get Nothing 59 | Just feed -> fetchFeedWith (Wreq.getWith (makeOpts feed)) (Just feed) 60 | where 61 | makeOpts :: Entity Feed -> Wreq.Options 62 | makeOpts (Entity _ Feed{..}) = Wreq.defaults 63 | & Wreq.header "If-Modified-Since" .~ [feedLastModified] 64 | & Wreq.header "If-None-Match" .~ [feedEtag] 65 | 66 | fetchFeedWith :: (String -> IO (Wreq.Response BSL.ByteString)) -> Maybe (Entity Feed) -> Handler Html 67 | fetchFeedWith get_request mfeed = catch action handler 68 | where 69 | action :: Handler Html 70 | action = liftIO (timed timeout (get_request $ T.unpack url)) >>= \case 71 | Nothing -> feedFailure . toHtml $ "Operation timed out after " <> T.pack (show timeout) <> " seconds." 72 | Just resp -> case XML.parseXMLDoc (resp ^. Wreq.responseBody) >>= parse_feed of 73 | Nothing -> feedFailure "Parse failed." 74 | Just parsed_feed -> do 75 | let title = make_title parsed_feed 76 | last_modified = resp ^. Wreq.responseHeader "Last-Modified" 77 | etag = resp ^. Wreq.responseHeader "ETag" 78 | contents = BSL.toStrict $ resp ^. Wreq.responseBody 79 | 80 | runDB $ case mfeed of 81 | Nothing -> insert_ (make_feed title url last_modified etag contents) 82 | Just (Entity feed_id _) -> updateFeed feed_id title last_modified etag contents 83 | 84 | defaultLayout $ make_widget parsed_feed 85 | 86 | handler :: HttpException -> Handler Html 87 | handler (StatusCodeException (Status 304 _) _ _) = do 88 | let 89 | -- Safe, because a 304 would only be sent if we set If-Modified-Since, 90 | -- which means the feed indeed already existed in the database. 91 | Just (Entity _ feed) = mfeed 92 | 93 | -- Safe, because we only insert valid RSS docs. 94 | Just parsed_feed = XML.parseXMLDoc (feedContents feed) >>= parse_feed 95 | 96 | defaultLayout $ make_widget parsed_feed 97 | handler (InvalidUrlException _ _) = feedFailure "Invalid URL." 98 | handler e = throwIO e 99 | 100 | getFeedsR :: Handler Html 101 | getFeedsR = do 102 | feeds <- runDB getAllFeeds 103 | defaultLayout $(widgetFile "feeds") 104 | -------------------------------------------------------------------------------- /src/Handler/ReqEditsHub.hs: -------------------------------------------------------------------------------- 1 | module Handler.ReqEditsHub where 2 | 3 | import Import 4 | 5 | import Handler.Utils (denyPermissionIfDifferentUser, denyPermissionIfNotAdmin) 6 | import Model.ResourceEdit 7 | import View.Resource (resourceInfoWidget) 8 | 9 | import qualified Data.Map as M 10 | import qualified Data.Set as S 11 | import qualified Data.Text as T 12 | 13 | getReqEditsHubR :: UserId -> Handler Html 14 | getReqEditsHubR uid = do 15 | denyPermissionIfDifferentUser uid 16 | runDB ((,,,,,,,) 17 | <$> fetchEditTitlesDB uid 18 | <*> fetchEditAuthorsDB uid 19 | <*> fetchEditPublishedDB uid 20 | <*> fetchEditTypesDB uid 21 | <*> fetchEditAddTagsDB uid 22 | <*> fetchEditRemoveTagsDB uid 23 | <*> fetchEditAddCollectionsDB uid 24 | <*> fetchEditRemoveCollectionsDB uid) 25 | >>= getRequestedEdits 26 | 27 | getAllEditsR :: Handler Html 28 | getAllEditsR = do 29 | denyPermissionIfNotAdmin 30 | runDB ((,,,,,,,) 31 | <$> fetchAllEditTitlesDB 32 | <*> fetchAllEditAuthorsDB 33 | <*> fetchAllEditPublishedDB 34 | <*> fetchAllEditTypesDB 35 | <*> fetchAllEditAddTagsDB 36 | <*> fetchAllEditRemoveTagsDB 37 | <*> fetchAllEditAddCollectionsDB 38 | <*> fetchAllEditRemoveCollectionsDB) 39 | >>= getRequestedEdits 40 | 41 | getRequestedEdits :: ( Map (Entity Resource) [Entity EditTitle] 42 | , Map (Entity Resource) [Entity EditAuthors] 43 | , Map (Entity Resource) [Entity EditPublished] 44 | , Map (Entity Resource) [Entity EditType] 45 | , Map (Entity Resource) [Entity EditAddTag] 46 | , Map (Entity Resource) [Entity EditRemoveTag] 47 | , Map (Entity Resource) [Entity EditAddCollection] 48 | , Map (Entity Resource) [Entity EditRemoveCollection] 49 | ) 50 | -> Handler Html 51 | getRequestedEdits ( editTitles 52 | , editAuthors 53 | , editPublished 54 | , editTypes 55 | , editAddTags 56 | , editRemoveTags 57 | , editAddCollections 58 | , editRemoveCollections 59 | ) = do 60 | let areNoRequestedEdits :: Bool 61 | areNoRequestedEdits = and 62 | [ M.null editTitles 63 | , M.null editAuthors 64 | , M.null editPublished 65 | , M.null editTypes 66 | , M.null editAddTags 67 | , M.null editRemoveTags 68 | , M.null editAddCollections 69 | , M.null editRemoveCollections 70 | ] 71 | 72 | resources :: Set (Entity Resource) 73 | resources = mconcat 74 | [ S.fromList (M.keys editTitles) 75 | , S.fromList (M.keys editAuthors) 76 | , S.fromList (M.keys editPublished) 77 | , S.fromList (M.keys editTypes) 78 | , S.fromList (M.keys editAddTags) 79 | , S.fromList (M.keys editRemoveTags) 80 | , S.fromList (M.keys editAddCollections) 81 | , S.fromList (M.keys editRemoveCollections) 82 | ] 83 | 84 | setUltDestCurrent 85 | defaultLayout $ do 86 | setTitle "dohaskell | requested edits" 87 | $(widgetFile "requested-edits-hub") 88 | -------------------------------------------------------------------------------- /src/Handler/Resource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module Handler.Resource where 4 | 5 | import Import 6 | 7 | import Model.List 8 | import Model.Resource 9 | import Model.User (thisUserHasAuthorityOverDB) 10 | import View.Browse 11 | import View.Resource 12 | 13 | import qualified Data.Set as S 14 | 15 | getResourceR :: ResourceId -> Handler Html 16 | getResourceR res_id = do 17 | (res@Resource{..}, authors, tags, colls) <- runDB $ (,,,) 18 | <$> get404 res_id 19 | <*> (map authorName <$> fetchResourceAuthorsDB res_id) 20 | <*> (map tagName <$> fetchResourceTagsDB res_id) 21 | <*> (map collectionName <$> fetchResourceCollectionsDB res_id) 22 | 23 | let info_widget = resourceInfoWidget (Entity res_id res) 24 | edit_widget = 25 | editResourceFormWidget 26 | res_id 27 | (Just resourceTitle) 28 | (Just authors) 29 | (Just resourcePublished) 30 | (Just resourceType) 31 | (Just tags) 32 | (Just colls) 33 | 34 | defaultLayout $ do 35 | setTitle . toHtml $ "dohaskell | " <> resourceTitle 36 | $(widgetFile "resource") 37 | 38 | getEditResourceR :: ResourceId -> Handler Html 39 | getEditResourceR res_id = do 40 | (Resource{..}, authors, tags, colls) <- runDB $ (,,,) 41 | <$> get404 res_id 42 | <*> (map authorName <$> fetchResourceAuthorsDB res_id) 43 | <*> (map tagName <$> fetchResourceTagsDB res_id) 44 | <*> (map collectionName <$> fetchResourceCollectionsDB res_id) 45 | 46 | defaultLayout $ 47 | editResourceFormWidget 48 | res_id 49 | (Just resourceTitle) 50 | (Just authors) 51 | (Just resourcePublished) 52 | (Just resourceType) 53 | (Just tags) 54 | (Just colls) 55 | 56 | postEditResourceR :: ResourceId -> Handler Html 57 | postEditResourceR res_id = do 58 | res <- runDB (get404 res_id) 59 | ((result, _), _) <- runFormPost (editResourceForm Nothing Nothing Nothing Nothing Nothing Nothing) 60 | case result of 61 | FormSuccess (new_title, new_authors, new_published, new_type, new_tags, new_colls) -> do 62 | ok <- thisUserHasAuthorityOverDB (resourceUserId res) 63 | if ok 64 | then do 65 | runDB $ updateResourceDB 66 | res_id 67 | new_title 68 | (map Author $ new_authors) 69 | new_published 70 | new_type 71 | (map Tag $ new_tags) 72 | (map Collection $ new_colls) 73 | setMessage "Resource updated." 74 | redirect $ ResourceR res_id 75 | -- An authenticated, unprivileged user is the same as an 76 | -- unauthenticated user - their edits result in pending 77 | -- edits. 78 | else doPendingEdit res 79 | where 80 | doPendingEdit :: Resource -> Handler Html 81 | doPendingEdit Resource{..} = do 82 | pendingEditField resourceTitle new_title EditTitle 83 | pendingEditField resourcePublished new_published EditPublished 84 | pendingEditField resourceType new_type EditType 85 | 86 | (old_authors, old_tags, old_colls) <- runDB $ (,,) 87 | <$> (map authorName <$> fetchResourceAuthorsDB res_id) 88 | <*> (map tagName <$> fetchResourceTagsDB res_id) 89 | <*> (map collectionName <$> fetchResourceCollectionsDB res_id) 90 | 91 | -- Authors are a little different than tags/collections, because 92 | -- order matters. So, -- we don't duplicate the fine-grained tag 93 | -- edits (individual add/remove), but rather, if *anything* 94 | -- about the authors changed, just make an edit containing all 95 | -- of them. 96 | when (old_authors /= new_authors) $ 97 | void $ runDB (insertUnique (EditAuthors res_id new_authors)) 98 | 99 | pendingEditRelation (S.fromList new_tags) (S.fromList old_tags) EditAddTag EditRemoveTag 100 | pendingEditRelation (S.fromList new_colls) (S.fromList old_colls) EditAddCollection EditRemoveCollection 101 | 102 | setMessage "Your edit has been submitted for approval. Thanks!" 103 | redirect $ ResourceR res_id 104 | where 105 | pendingEditField :: (Eq a, PersistEntity val, PersistEntityBackend val ~ SqlBackend) 106 | => a -- Old field value 107 | -> a -- New field value 108 | -> (ResourceId -> a -> val) -- PersistEntity constructor 109 | -> Handler () 110 | pendingEditField old_value new_value entityConstructor = 111 | when (old_value /= new_value) $ 112 | void . runDB . insertUnique $ entityConstructor res_id new_value 113 | 114 | pendingEditRelation :: (PersistEntity a, PersistEntityBackend a ~ SqlBackend, 115 | PersistEntity b, PersistEntityBackend b ~ SqlBackend, 116 | Ord field) 117 | => Set field 118 | -> Set field 119 | -> (ResourceId -> field -> a) 120 | -> (ResourceId -> field -> b) 121 | -> Handler () 122 | pendingEditRelation new_fields old_fields edit_add edit_remove = do 123 | pendingEditRelation' new_fields old_fields edit_add -- find any NEW not in OLD: pending ADD. 124 | pendingEditRelation' old_fields new_fields edit_remove -- find any OLD not in NEW: pending REMOVE. 125 | 126 | -- If we find any needles NOT in the haystack, insert the needle into the database 127 | -- with the supplied constructor. 128 | pendingEditRelation' :: (Ord field, PersistEntity val, PersistEntityBackend val ~ SqlBackend) 129 | => Set field 130 | -> Set field 131 | -> (ResourceId -> field -> val) 132 | -> Handler () 133 | pendingEditRelation' needles haystack edit_constructor = 134 | forM_ needles $ \needle -> 135 | unless (S.member needle haystack) $ 136 | void . runDB . insertUnique $ edit_constructor res_id needle 137 | 138 | FormFailure errs -> do 139 | setMessage . toHtml $ "Form error: " <> intercalate ", " errs 140 | redirect $ ResourceR res_id 141 | FormMissing -> redirect $ ResourceR res_id 142 | 143 | getResourceListR :: Text -> Handler Html 144 | getResourceListR list_name = 145 | requireAuthId 146 | >>= runDB . flip fetchListResourcesDB list_name 147 | >>= defaultLayout . resourceListWidget 148 | 149 | postResourceListAddR, postResourceListDelR :: Text -> ResourceId -> Handler Html 150 | postResourceListAddR = postResourceListAddDel addListItemDB 151 | postResourceListDelR = postResourceListAddDel deleteListItemDB 152 | 153 | postResourceListAddDel :: (UserId -> Text -> ResourceId -> YesodDB App ()) -> Text -> ResourceId -> Handler Html 154 | postResourceListAddDel action list_name res_id = do 155 | user_id <- requireAuthId 156 | runDB (action user_id list_name res_id) 157 | return "ok" 158 | -------------------------------------------------------------------------------- /src/Handler/Submit.hs: -------------------------------------------------------------------------------- 1 | module Handler.Submit where 2 | 3 | import Import 4 | 5 | import Database.Persist.Class.Extra (insertBy') 6 | import View.Resource (resourceForm) 7 | 8 | getSubmitR :: Handler Html 9 | getSubmitR = do 10 | uid <- requireAuthId 11 | (widget, enctype) <- generateFormPost (resourceForm uid) 12 | defaultLayout $ do 13 | setTitle "dohaskell | submit" 14 | $(widgetFile "submit") 15 | 16 | postSubmitR :: Handler Html 17 | postSubmitR = do 18 | ((result, _), _) <- runFormPost . resourceForm =<< requireAuthId 19 | case result of 20 | FormSuccess (title, url, authors, year, typ, tags, colls, user_id, posted_at) -> do 21 | let res = Resource title url year typ user_id posted_at 22 | runDB (insertBy res) >>= \case 23 | Left (Entity res_id _) -> do 24 | setDuplicateUrlMessage (resourceUrl res) res_id 25 | redirect SubmitR 26 | Right res_id -> do 27 | runDB $ do 28 | mapM_ (insertResAuthorAndAuthor res_id) (zip [0..] authors) 29 | mapM_ (insertTagOrCollection Tag ResourceTag res_id) tags 30 | mapM_ (insertTagOrCollection Collection ResCollection res_id) colls 31 | setMessage "Thanks for your submission!" 32 | redirect HomeR 33 | _ -> do 34 | setMessage "Invalid resource submission! Please try again." 35 | redirect SubmitR 36 | where 37 | insertResAuthorAndAuthor :: ResourceId -> (Int, Text) -> YesodDB App () 38 | insertResAuthorAndAuthor res_id (n, name) = do 39 | auth_id <- insertBy' (Author name) 40 | void . insertUnique $ ResAuthor res_id auth_id n 41 | 42 | insertTagOrCollection entity relation res_id name = 43 | void $ insertBy' (entity name) >>= insertUnique . relation res_id 44 | 45 | 46 | setDuplicateUrlMessage :: Text -> ResourceId -> Handler () 47 | setDuplicateUrlMessage resUrl resId = do 48 | withUrlRenderer [hamlet| 49 | URL "#{resUrl}" already exists. 50 | Take me there. 51 | |] >>= setMessage 52 | -------------------------------------------------------------------------------- /src/Handler/User.hs: -------------------------------------------------------------------------------- 1 | module Handler.User where 2 | 3 | import Import 4 | 5 | import Handler.Utils (denyPermissionIfDifferentUser) 6 | import Model.List 7 | import Model.ResourceEdit (fetchNumRequestedEditsDB) 8 | import Model.User 9 | import Model.Utils 10 | import View.Browse 11 | import View.User 12 | 13 | import qualified Data.Text as T 14 | 15 | plural :: Int -> Text -> Text 16 | plural 1 = id 17 | plural _ = flip T.snoc 's' 18 | 19 | getUserR :: UserId -> Handler Html 20 | getUserR user_id = do 21 | user <- runDB $ get404 user_id 22 | (widget, enctype) <- generateFormPost (displayNameForm . Just $ userDisplayName user) 23 | 24 | is_own_profile <- maybe False (== user_id) <$> maybeAuthId 25 | (num_req_edits, num_submitted, num_grokked) <- runDB $ (,,) 26 | <$> (if is_own_profile then fetchNumRequestedEditsDB user_id else return 0) -- bogus val, not used in html 27 | <*> fetchNumSubmittedResourcesDB user_id 28 | <*> fetchNumGrokkedResourcesDB user_id 29 | 30 | defaultLayout $ do 31 | setTitle "dohaskell | profile" 32 | $(widgetFile "user") 33 | 34 | postUserR :: UserId -> Handler Html 35 | postUserR user_id = do 36 | denyPermissionIfDifferentUser user_id 37 | ((result, _), _) <- runFormPost (displayNameForm Nothing) 38 | case result of 39 | FormSuccess displayName -> do 40 | runDB (updateUserDisplayNameDB user_id displayName) 41 | setMessage "Display name updated." 42 | redirect $ UserR user_id 43 | FormFailure err -> userFormFailure ("Form failure: " <> T.intercalate "," err) 44 | FormMissing -> userFormFailure ("Form missing") 45 | where 46 | userFormFailure :: Text -> Handler a 47 | userFormFailure msg = do 48 | setMessage (toHtml msg) 49 | redirect (UserR user_id) 50 | 51 | getUserSubmittedR :: UserId -> Handler Html 52 | getUserSubmittedR user_id = do 53 | (display_name, unsorted_resources) <- runDB $ (,) 54 | <$> (userDisplayName <$> get404 user_id) 55 | <*> fetchSubmittedResourcesDB user_id 56 | 57 | let resources = sortBy (orderAlphabeticIgnoreCase (resourceTitle . entityVal)) unsorted_resources 58 | 59 | defaultLayout $ do 60 | setTitle . toHtml $ "dohaskell | submitted by " <> display_name 61 | resourceListWidget resources 62 | 63 | getUserListR :: UserId -> Text -> Handler Html 64 | getUserListR user_id list_name = 65 | runDB (fetchListResourcesDB user_id list_name) 66 | >>= defaultLayout . resourceListWidget 67 | -------------------------------------------------------------------------------- /src/Handler/Utils.hs: -------------------------------------------------------------------------------- 1 | module Handler.Utils 2 | ( SortBy(..) 3 | , addGetParam 4 | , getCurrentRouteWithGetParams 5 | , denyPermissionIfDifferentUser 6 | , denyPermissionIfDoesntHaveAuthorityOver 7 | , denyPermissionIfNotAdmin 8 | , prettyAgo 9 | ) where 10 | 11 | import Import 12 | 13 | import Model.Browse 14 | import Model.User (isAdministratorDB, userHasAuthorityOverDB) 15 | 16 | import Data.Maybe (fromJust) 17 | import qualified Data.Map as M 18 | import qualified Data.Text as T 19 | import Data.Time 20 | 21 | denyPermissionIfDifferentUser :: UserId -> Handler () 22 | denyPermissionIfDifferentUser requestedUser = maybeAuthId >>= \case 23 | Nothing -> deny 24 | Just thisUser -> 25 | runDB (get requestedUser) >>= \case 26 | Nothing -> notFound 27 | Just _ -> when (requestedUser /= thisUser) 28 | deny 29 | 30 | denyPermissionIfDoesntHaveAuthorityOver :: UserId -> Handler () 31 | denyPermissionIfDoesntHaveAuthorityOver nerd = maybeAuthId >>= \case 32 | Nothing -> deny 33 | Just bully -> 34 | runDB (get nerd) >>= \case 35 | Nothing -> notFound 36 | Just _ -> do 37 | ok <- runDB $ userHasAuthorityOverDB bully nerd 38 | when (not ok) 39 | deny 40 | 41 | denyPermissionIfNotAdmin :: Handler () 42 | denyPermissionIfNotAdmin = maybeAuthId >>= \case 43 | Nothing -> deny 44 | Just uid -> runDB (isAdministratorDB uid) >>= \b -> unless b deny 45 | 46 | deny :: Handler () 47 | deny = permissionDenied "You don't have permission to view this page." 48 | 49 | -- | Pretty-print a time "ago". 50 | -- TODO: Find a better home for this function. 51 | prettyAgo :: (Functor m, MonadIO m) => UTCTime -> m Text 52 | prettyAgo t = do 53 | secs_ago <- round . flip diffUTCTime t <$> liftIO getCurrentTime 54 | if | secs_ago < secsPerWeek -> return $ prettyAgo' secsPerDay "today" " day" secs_ago 55 | | secs_ago < secsPerMonth -> return $ prettyAgo' secsPerWeek "last week" " week" secs_ago 56 | | secs_ago < secsPerYear -> return $ prettyAgo' secsPerMonth "last month" " month" secs_ago 57 | | otherwise -> return $ prettyAgo' secsPerYear "last year" " year" secs_ago 58 | where 59 | prettyAgo' :: Integer -> Text -> Text -> Integer -> Text 60 | prettyAgo' divisor if_one_text if_many_text secs_ago = 61 | case secs_ago `div` divisor of 62 | 0 -> if_one_text 63 | n -> T.pack (show n) <> plural n if_many_text <> " ago" 64 | 65 | plural :: Integer -> Text -> Text 66 | plural 1 = id 67 | plural _ = flip T.snoc 's' 68 | 69 | secsPerDay, secsPerWeek, secsPerMonth, secsPerYear :: Integer 70 | secsPerDay = 86400 -- 60*60*24 71 | secsPerWeek = 604800 -- 60*60*24*7 72 | secsPerMonth = 2592000 -- 60*60*24*30 73 | secsPerYear = 31536000 -- 60*60*24*365 74 | 75 | -- | Get the current route with the current GET params. 76 | -- Unsafe if getCurrentRoute would return Nothing. 77 | getCurrentRouteWithGetParams :: Handler (Route App, [(Text, Text)]) 78 | getCurrentRouteWithGetParams = (,) 79 | <$> (fromJust <$> getCurrentRoute) 80 | <*> (reqGetParams <$> getRequest) 81 | 82 | -- | Add a new GET param to a list of GET params. 83 | addGetParam :: (Text, Text) -> [(Text, Text)] -> [(Text, Text)] 84 | addGetParam (k,v) = M.toList . M.insert k v . M.fromList 85 | -------------------------------------------------------------------------------- /src/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module Import 3 | ) where 4 | 5 | import Foundation as Import 6 | import Import.NoFoundation as Import 7 | 8 | import Database.Esqueleto 9 | 10 | class FromValue a where 11 | type UnValue a 12 | fromValue :: a -> UnValue a 13 | 14 | instance FromValue (Value a) where 15 | type UnValue (Value a) = a 16 | fromValue = unValue 17 | 18 | instance (FromValue a, FromValue b) => FromValue (a, b) where 19 | type UnValue (a, b) = (UnValue a, UnValue b) 20 | fromValue (a, b) = (fromValue a, fromValue b) 21 | 22 | instance (FromValue a, FromValue b, FromValue c) => FromValue (a, b, c) where 23 | type UnValue (a, b, c) = (UnValue a, UnValue b, UnValue c) 24 | fromValue (a, b, c) = (fromValue a, fromValue b, fromValue c) 25 | -------------------------------------------------------------------------------- /src/Import/NoFoundation.hs: -------------------------------------------------------------------------------- 1 | module Import.NoFoundation 2 | ( module Import 3 | ) where 4 | 5 | import ClassyPrelude.Yesod as Import hiding (Feed(..), Value(..), (=.), (==.), delete, groupBy, on, update) 6 | import Model as Import 7 | import Settings as Import 8 | import Settings.StaticFiles as Import 9 | import Yesod.Auth as Import 10 | import Yesod.Core.Types as Import (loggerSet) 11 | import Yesod.Default.Config2 as Import 12 | -------------------------------------------------------------------------------- /src/Model.hs: -------------------------------------------------------------------------------- 1 | module Model where 2 | 3 | import Model.Feed.Internal 4 | import Model.Resource.Internal 5 | 6 | import Data.ByteString (ByteString) 7 | import Data.Text (Text) 8 | import Data.Time (UTCTime) 9 | import Data.Typeable (Typeable) 10 | import Database.Persist.Quasi 11 | import Prelude (Bool, Eq, Int, Ord) 12 | import Yesod 13 | import Yesod.Markdown (Markdown) 14 | 15 | -- You can define all of your database entities in the entities file. 16 | -- You can find more information on persistent and how to declare entities 17 | -- at: 18 | -- http://www.yesodweb.com/book/persistent/ 19 | 20 | share [ mkPersist sqlSettings 21 | , mkMigrate "migrateAll" 22 | , mkDeleteCascade sqlSettings 23 | ] 24 | $(persistFileWith lowerCaseSettings "config/models") 25 | -------------------------------------------------------------------------------- /src/Model/Author.hs: -------------------------------------------------------------------------------- 1 | module Model.Author where 2 | 3 | import Import 4 | 5 | import Model.Resource 6 | 7 | -- | Get all authors. 8 | fetchAllAuthorsDB :: YesodDB App [Entity Author] 9 | fetchAllAuthorsDB = selectList [] [] 10 | 11 | -- | Get a map of AuthorId to the number of Resources with that Author. 12 | fetchAuthorResourceCountsDB :: YesodDB App (Map AuthorId Int) 13 | fetchAuthorResourceCountsDB = fetchResourceFieldCountsDB ResAuthorAuthId 14 | 15 | -- | Get the year range of all Resources of an Author. If none of the Author's Resources 16 | -- have any published year, then the AuthorId will not exist in the returned map. 17 | fetchAuthorYearRangesDB :: YesodDB App (Map AuthorId (Int, Int)) 18 | fetchAuthorYearRangesDB = fetchResourceFieldYearRangesDB ResAuthorResId ResAuthorAuthId 19 | -------------------------------------------------------------------------------- /src/Model/Browse.hs: -------------------------------------------------------------------------------- 1 | module Model.Browse 2 | ( BrowseByLink(..) 3 | , SortBy(..) 4 | ) where 5 | 6 | import Import 7 | 8 | data BrowseByLink 9 | = BrowseByAuthorLink 10 | | BrowseByCollectionLink 11 | | BrowseByResourceLink 12 | | BrowseByTagLink 13 | | BrowseByTypeLink 14 | deriving Eq 15 | 16 | data SortBy 17 | = SortByAZ 18 | | SortByCountUp -- lowest count at top 19 | | SortByCountDown -- highest count at top 20 | | SortByYearUp -- earliest year at top 21 | | SortByYearDown -- latest year at top 22 | | SortByRecentlyAdded -- latest submission at top 23 | deriving Eq 24 | 25 | instance Show SortBy where 26 | show SortByAZ = "a-z" 27 | show SortByCountUp = "count-up" 28 | show SortByCountDown = "count-down" 29 | show SortByYearUp = "year-up" 30 | show SortByYearDown = "year-down" 31 | show SortByRecentlyAdded = "recently-added" 32 | -------------------------------------------------------------------------------- /src/Model/Collection.hs: -------------------------------------------------------------------------------- 1 | module Model.Collection where 2 | 3 | import Import 4 | 5 | import Model.Resource 6 | 7 | -- | Get all Collections. 8 | fetchAllCollectionsDB :: YesodDB App [Entity Collection] 9 | fetchAllCollectionsDB = selectList [] [] 10 | 11 | -- | Get a map of CollectionId to the number of Resources in that Collection 12 | fetchCollectionResourceCountsDB :: YesodDB App (Map CollectionId Int) 13 | fetchCollectionResourceCountsDB = fetchResourceFieldCountsDB ResCollectionColId 14 | 15 | -- | Get the year range of all Resources of with a specific Tag. If none of the 16 | -- Resources with that Tag have any published year, then the Tag will not exist 17 | -- in the returned map. 18 | fetchCollectionYearRangesDB :: YesodDB App (Map CollectionId (Int, Int)) 19 | fetchCollectionYearRangesDB = fetchResourceFieldYearRangesDB ResCollectionResId ResCollectionColId 20 | -------------------------------------------------------------------------------- /src/Model/Feed.hs: -------------------------------------------------------------------------------- 1 | module Model.Feed 2 | ( getAllFeeds 3 | , getFeed 4 | , updateFeed 5 | , module Model.Feed.Internal 6 | ) where 7 | 8 | import Import 9 | 10 | import Model.Feed.Internal 11 | 12 | import Database.Esqueleto 13 | 14 | -- | Get all feed (title, url, type) 3-tuples. 15 | getAllFeeds :: YesodDB App [(Text, Text, FeedType)] 16 | getAllFeeds = fmap (map fromValue) $ 17 | select $ 18 | from $ \f -> do 19 | orderBy [asc (f^.FeedUrl)] 20 | return (f^.FeedTitle, f^.FeedUrl, f^.FeedType) 21 | 22 | getFeed :: Text -> YesodDB App (Maybe (Entity Feed)) 23 | getFeed = getBy . UniqueFeed 24 | 25 | updateFeed :: FeedId -> Text -> ByteString -> ByteString -> ByteString -> YesodDB App () 26 | updateFeed feed_id title last_modified etag contents = 27 | update $ \f -> do 28 | set f [ FeedTitle =. val title 29 | , FeedLastModified =. val last_modified 30 | , FeedEtag =. val etag 31 | , FeedContents =. val contents 32 | ] 33 | where_ (f^.FeedId ==. val feed_id) 34 | -------------------------------------------------------------------------------- /src/Model/Feed/Internal.hs: -------------------------------------------------------------------------------- 1 | module Model.Feed.Internal where 2 | 3 | import Prelude 4 | 5 | import Text.ParserCombinators.ReadPrec (lift) 6 | import Text.ParserCombinators.ReadP ((+++), string) 7 | import Text.Read (readPrec) 8 | 9 | import Database.Persist.TH (derivePersistField) 10 | 11 | data FeedType 12 | = Atom 13 | | RSS2 14 | deriving Eq 15 | 16 | instance Show FeedType where 17 | show Atom = "atom" 18 | show RSS2 = "rss" 19 | 20 | instance Read FeedType where 21 | readPrec = lift $ (Atom <$ string "atom") +++ (RSS2 <$ string "rss") 22 | 23 | derivePersistField "FeedType" 24 | -------------------------------------------------------------------------------- /src/Model/List.hs: -------------------------------------------------------------------------------- 1 | module Model.List 2 | ( addListItemDB 3 | , deleteListItemDB 4 | , fetchGrokkedListIdDB 5 | , fetchListLengthDB 6 | , fetchListResourcesDB 7 | ) where 8 | 9 | import Import 10 | 11 | import Database.Persist.Class.Extra 12 | 13 | import Database.Esqueleto 14 | import qualified Database.Persist as P 15 | 16 | -- | Add a Resource to a User's List. Creates the List if it doesn't already 17 | -- exist. No-op if the Resource is already in the List. 18 | addListItemDB :: UserId -> Text -> ResourceId -> YesodDB App () 19 | addListItemDB user_id list_name res_id = 20 | insertBy' (List list_name) >>= \list_id -> 21 | liftIO getCurrentTime >>= void . insertUnique . ListItem user_id list_id res_id 22 | 23 | -- | Delete a Resource from a User's List. Deletes the List if it no longer has 24 | -- any Resources. No-op if the Resource is not in the List. 25 | deleteListItemDB :: UserId -> Text -> ResourceId -> YesodDB App () 26 | deleteListItemDB user_id list_name res_id = 27 | getBy (UniqueList list_name) >>= maybe (return ()) (go . entityKey) 28 | where 29 | go :: ListId -> YesodDB App () 30 | go list_id = do 31 | deleteBy (UniqueListItem user_id list_id res_id) 32 | fetchListLengthDB list_id >>= \case 33 | 0 -> P.delete list_id 34 | _ -> return () 35 | 36 | -- | Get all Resources that belong to a User's List. 37 | fetchListResourcesDB :: UserId -> Text -> YesodDB App [Entity Resource] 38 | fetchListResourcesDB user_id list_name = 39 | select $ 40 | from $ \(l `InnerJoin` li `InnerJoin` r) -> do 41 | on (li^.ListItemResId ==. r^.ResourceId) 42 | on (l^.ListId ==. li^.ListItemListId) 43 | where_ $ 44 | l^.ListName ==. val list_name &&. 45 | li^.ListItemUserId ==. val user_id 46 | return r 47 | 48 | fetchGrokkedListIdDB :: YesodDB App (Maybe ListId) 49 | fetchGrokkedListIdDB = fmap entityKey <$> getBy (UniqueList "grokked") 50 | 51 | -- | Get the number of Resources added to this List by all Users. 52 | fetchListLengthDB :: ListId -> YesodDB App Int 53 | fetchListLengthDB list_id = fmap (\[Value n] -> n) $ 54 | select $ 55 | from $ \li -> do 56 | where_ (li^.ListItemListId ==. val list_id) 57 | return (countRows :: SqlExpr (Value Int)) 58 | -------------------------------------------------------------------------------- /src/Model/Resource.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Model.Resource 4 | ( fetchAllResourcesDB 5 | , fetchResourceAuthorsDB 6 | , fetchResourceAuthorsInDB 7 | , fetchResourceCollectionsDB 8 | , fetchResourceFieldCountsDB 9 | , fetchResourceFieldYearRangesDB 10 | , fetchResourceGrokkedCountsInDB 11 | , fetchResourcesByAuthorDB 12 | , fetchResourcesInCollectionDB 13 | , fetchResourcesWithTagDB 14 | , fetchResourcesWithTypeDB 15 | , fetchResourceTagsDB 16 | , fetchResourceTypeCountsDB 17 | , fetchResourceTypeYearRangesDB 18 | , resourceExtension 19 | , updateResourceDB 20 | , updateResourceAuthorsDB 21 | , module Model.Resource.Internal 22 | ) where 23 | 24 | import Import 25 | import Model.Resource.Internal 26 | 27 | import Model.List 28 | 29 | import qualified Data.DList as DL 30 | import qualified Data.Map as M 31 | import qualified Data.Text as T 32 | import Database.Esqueleto 33 | 34 | -- | Grab the "important" extension of this resource (pdf, ps, etc). for 35 | -- visual display (for instance, so mobile users don't download pdfs 36 | -- accidentally). 37 | resourceExtension :: Resource -> Maybe Text 38 | resourceExtension res = case T.breakOnEnd "." (resourceUrl res) of 39 | (_, "pdf") -> Just "pdf" 40 | (_, "ps") -> Just "ps" 41 | _ -> Nothing 42 | 43 | -- | Get all resources. 44 | fetchAllResourcesDB 45 | :: (SqlExpr (Value ResourceId) -> SqlExpr OrderBy) 46 | -> Int64 47 | -> Int64 48 | -> YesodDB App [Entity Resource] 49 | fetchAllResourcesDB order lim off = 50 | select $ 51 | from $ \r -> do 52 | orderBy [order (r^.ResourceId)] 53 | limit lim 54 | offset off 55 | pure r 56 | 57 | -- | Get the Authors of a Resource. 58 | fetchResourceAuthorsDB :: ResourceId -> YesodDB App [Author] 59 | fetchResourceAuthorsDB res_id = fmap (map entityVal) $ 60 | select $ 61 | from $ \(a `InnerJoin` ra) -> do 62 | on (a^.AuthorId ==. ra^.ResAuthorAuthId) 63 | where_ (ra^.ResAuthorResId ==. val res_id) 64 | orderBy [asc (ra^.ResAuthorOrd)] 65 | return a 66 | 67 | -- | Get the Authors of a list of Resources, as a Map. 68 | fetchResourceAuthorsInDB :: [ResourceId] -> YesodDB App (Map ResourceId [Author]) 69 | fetchResourceAuthorsInDB res_ids = fmap makeAuthorMap $ 70 | select $ 71 | from $ \(a `InnerJoin` ra) -> do 72 | on (a^.AuthorId ==. ra^.ResAuthorAuthId) 73 | where_ (ra^.ResAuthorResId `in_` valList res_ids) 74 | orderBy [asc (ra^.ResAuthorOrd)] 75 | return (ra^.ResAuthorResId, a) 76 | where 77 | makeAuthorMap :: [(Value ResourceId, Entity Author)] -> Map ResourceId [Author] 78 | makeAuthorMap = fmap DL.toList . foldr step mempty 79 | where 80 | step :: (Value ResourceId, Entity Author) 81 | -> Map ResourceId (DList Author) 82 | -> Map ResourceId (DList Author) 83 | step (Value res_id, Entity _ author) = M.insertWith (<>) res_id (DL.singleton author) 84 | 85 | fetchResourcesByAuthorDB :: Text -> Int64 -> Int64 -> YesodDB App [Entity Resource] 86 | fetchResourcesByAuthorDB = fetchResourcesWithFieldDB UniqueAuthor ResAuthorResId ResAuthorAuthId 87 | 88 | fetchResourcesInCollectionDB :: Text -> Int64 -> Int64 -> YesodDB App [Entity Resource] 89 | fetchResourcesInCollectionDB = fetchResourcesWithFieldDB UniqueCollection ResCollectionResId ResCollectionColId 90 | 91 | fetchResourcesWithTagDB :: Text -> Int64 -> Int64 -> YesodDB App [Entity Resource] 92 | fetchResourcesWithTagDB = fetchResourcesWithFieldDB UniqueTag ResourceTagResId ResourceTagTagId 93 | 94 | -- | Abstract fetching all Resources with a particular Text field (Author/Collection/Tag). 95 | fetchResourcesWithFieldDB :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 96 | PersistEntity relation, PersistEntityBackend relation ~ SqlBackend) 97 | => (Text -> Unique entity) 98 | -> EntityField relation ResourceId 99 | -> EntityField relation (Key entity) 100 | -> Text 101 | -> Int64 102 | -> Int64 103 | -> YesodDB App [Entity Resource] 104 | fetchResourcesWithFieldDB unique_entity res_id_field key_field name lim off = 105 | getBy (unique_entity name) >>= \case 106 | Nothing -> return [] 107 | Just (Entity key _) -> 108 | select $ 109 | from $ \(r `InnerJoin` table) -> do 110 | on (r^.ResourceId ==. table^.res_id_field) 111 | where_ (table^.key_field ==. val key) 112 | limit lim 113 | offset off 114 | return r 115 | 116 | fetchResourcesWithTypeDB :: ResourceType -> Int64 -> Int64 -> YesodDB App [Entity Resource] 117 | fetchResourcesWithTypeDB res_type lim off = 118 | select $ 119 | from $ \r -> do 120 | where_ (r^.ResourceType ==. val res_type) 121 | limit lim 122 | offset off 123 | return r 124 | 125 | fetchResourceTagsDB :: ResourceId -> YesodDB App [Tag] 126 | fetchResourceTagsDB res_id = fmap (map entityVal) $ 127 | select $ 128 | from $ \(t `InnerJoin` rt) -> do 129 | on (t^.TagId ==. rt^.ResourceTagTagId) 130 | where_ (rt^.ResourceTagResId ==. val res_id) 131 | orderBy [asc (t^.TagName)] 132 | return t 133 | 134 | fetchResourceCollectionsDB :: ResourceId -> YesodDB App [Collection] 135 | fetchResourceCollectionsDB res_id = fmap (map entityVal) $ 136 | select $ 137 | from $ \(c `InnerJoin` rc) -> do 138 | on (c^.CollectionId ==. rc^.ResCollectionColId) 139 | where_ (rc^.ResCollectionResId ==. val res_id) 140 | orderBy [asc (c^.CollectionName)] 141 | return c 142 | 143 | -- | Update a resource. 144 | updateResourceDB 145 | :: ResourceId 146 | -> Text -- ^ Title 147 | -> [Author] 148 | -> Maybe Int -- ^ Year published 149 | -> ResourceType 150 | -> [Tag] 151 | -> [Collection] 152 | -> YesodDB App () 153 | updateResourceDB res_id title authors published typ tags colls = do 154 | updateTitlePublishedType 155 | updateResourceAuthorsDB res_id authors 156 | updateTags 157 | updateCollections 158 | where 159 | updateTitlePublishedType = 160 | update $ \r -> do 161 | set r [ ResourceTitle =. val title 162 | , ResourcePublished =. val published 163 | , ResourceType =. val typ 164 | ] 165 | where_ (r^.ResourceId ==. val res_id) 166 | 167 | updateTags = updateEntitiesAndRelations TagId ResourceTag ResourceTagResId ResourceTagTagId tags 168 | updateCollections = updateEntitiesAndRelations CollectionId ResCollection ResCollectionResId ResCollectionColId colls 169 | 170 | updateEntitiesAndRelations :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 171 | PersistEntity relation, PersistEntityBackend relation ~ SqlBackend) 172 | => EntityField entity (Key entity) 173 | -> (ResourceId -> Key entity -> relation) 174 | -> EntityField relation ResourceId 175 | -> EntityField relation (Key entity) 176 | -> [entity] 177 | -> YesodDB App () 178 | updateEntitiesAndRelations id_field relation relation_res_field relation_id_field vals = do 179 | deleteWithFkeyOnResource relation_res_field 180 | insertEntitiesAndRelations relation vals 181 | deleteUnusedEntities id_field relation_id_field 182 | 183 | deleteWithFkeyOnResource :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend) 184 | => EntityField entity ResourceId 185 | -> YesodDB App () 186 | deleteWithFkeyOnResource fkey = 187 | delete $ 188 | from $ \table -> 189 | where_ (table^.fkey ==. val res_id) 190 | 191 | insertEntitiesAndRelations :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 192 | PersistEntity relation, PersistEntityBackend relation ~ SqlBackend) 193 | => (ResourceId -> Key entity -> relation) 194 | -> [entity] 195 | -> YesodDB App () 196 | insertEntitiesAndRelations entity vals = 197 | mapM (fmap (either entityKey id) . insertBy) vals >>= void . insertMany . map (entity res_id) 198 | 199 | deleteUnusedEntities :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 200 | PersistEntity relation, PersistEntityBackend relation ~ SqlBackend) 201 | => EntityField entity (Key entity) 202 | -> EntityField relation (Key entity) 203 | -> YesodDB App () 204 | deleteUnusedEntities id_field relation_id_field = 205 | delete $ 206 | from $ \table -> 207 | where_ (table^.id_field `notIn` (subList_select $ distinct $ 208 | from $ \relation_table -> 209 | return (relation_table^.relation_id_field))) 210 | 211 | updateResourceAuthorsDB :: ResourceId -> [Author] -> YesodDB App () 212 | updateResourceAuthorsDB res_id authors = do 213 | deleteResAuthors 214 | insertAuthors >>= insertResAuthors 215 | deleteUnusedAuthors 216 | where 217 | deleteResAuthors = 218 | delete $ 219 | from $ \ra -> 220 | where_ (ra^.ResAuthorResId ==. val res_id) 221 | 222 | insertAuthors :: YesodDB App [AuthorId] 223 | insertAuthors = mapM (fmap (either entityKey id) . insertBy) authors 224 | 225 | insertResAuthors :: [AuthorId] -> YesodDB App () 226 | insertResAuthors = void . insertMany . map (\(n,auth_id) -> ResAuthor res_id auth_id n) . zip [0..] 227 | 228 | deleteUnusedAuthors = 229 | delete $ 230 | from $ \a -> 231 | where_ (a^.AuthorId `notIn` (subList_select $ distinct $ 232 | from $ \ra -> 233 | return (ra^.ResAuthorAuthId))) 234 | 235 | -- | Get a map of ResourceType to the number of Resources with that type. 236 | fetchResourceTypeCountsDB :: YesodDB App (Map ResourceType Int) 237 | fetchResourceTypeCountsDB = fetchResourceFieldCountsDB ResourceType 238 | 239 | fetchResourceFieldCountsDB :: forall entity key. 240 | (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 241 | PersistField key, Ord key) 242 | => EntityField entity key -> YesodDB App (Map key Int) 243 | fetchResourceFieldCountsDB key = fmap (M.fromList . map fromValue) sel 244 | where 245 | sel :: YesodDB App [(Value key, Value Int)] 246 | sel = select $ 247 | from $ \table -> do 248 | groupBy (table^.key) 249 | return (table^.key, countRows) 250 | 251 | fetchResourceTypeYearRangesDB :: YesodDB App (Map ResourceType (Int, Int)) 252 | fetchResourceTypeYearRangesDB = fmap (foldr mkYearMap mempty) $ 253 | select $ 254 | from $ \r -> do 255 | groupBy (r^.ResourceType) 256 | return (r^.ResourceType, min_ (r^.ResourcePublished), max_ (r^.ResourcePublished)) 257 | 258 | fetchResourceFieldYearRangesDB 259 | :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, PersistField field, Ord field) 260 | => EntityField entity ResourceId 261 | -> EntityField entity field -> YesodDB App (Map field (Int, Int)) 262 | fetchResourceFieldYearRangesDB res_id_field field = fmap (foldr mkYearMap mempty) $ 263 | select $ 264 | from $ \(r `InnerJoin` table) -> do 265 | on (r^.ResourceId ==. table^.res_id_field) 266 | groupBy (table^.field) 267 | return (table^.field, min_ (r^.ResourcePublished), max_ (r^.ResourcePublished)) 268 | 269 | mkYearMap :: Ord v 270 | => (Value v, Value (Maybe (Maybe Int)), Value (Maybe (Maybe Int))) 271 | -> Map v (Int, Int) 272 | -> Map v (Int, Int) 273 | mkYearMap (Value _, Value (Just Nothing), Value (Just Nothing)) = id 274 | mkYearMap (Value v, Value (Just (Just m)), Value Nothing) = M.insert v (m, m) 275 | mkYearMap (Value v, Value Nothing, Value (Just (Just m))) = M.insert v (m, m) 276 | mkYearMap (Value v, Value (Just (Just m)), Value (Just (Just n))) = M.insert v (m, n) 277 | mkYearMap (_, Value Nothing, Value Nothing) = id 278 | -- How could min_ return NULL but max not, or vice versa? 279 | mkYearMap (_, _, _) = error "fetchResourceFieldYearRangesDB: incorrect assumption about return value of min_/max_" 280 | 281 | -- | Given a list of Resources, get how many times each has been grokked. 282 | fetchResourceGrokkedCountsInDB :: [ResourceId] -> YesodDB App (Map ResourceId Int) 283 | fetchResourceGrokkedCountsInDB res_ids = 284 | fetchGrokkedListIdDB >>= \case 285 | Nothing -> return mempty -- no one has grokked anything 286 | Just grokked_list_id -> fmap (foldr go mempty) $ 287 | select $ 288 | from $ \li -> do 289 | where_ $ 290 | li^.ListItemListId ==. val grokked_list_id &&. 291 | li^.ListItemResId `in_` valList res_ids 292 | groupBy (li^.ListItemResId) 293 | return (li^.ListItemResId, countRows) 294 | where 295 | go :: (Value ResourceId, Value Int) -> Map ResourceId Int -> Map ResourceId Int 296 | go (Value res_id, Value n) = M.insert res_id n 297 | -------------------------------------------------------------------------------- /src/Model/Resource/Internal.hs: -------------------------------------------------------------------------------- 1 | module Model.Resource.Internal where 2 | 3 | import Prelude 4 | 5 | import Database.Persist.TH (derivePersistField) 6 | import Data.Text (Text) 7 | import Text.Blaze (ToMarkup, preEscapedToMarkup, toMarkup) 8 | 9 | data ResourceType 10 | = BlogPost 11 | | CommunitySite 12 | | Dissertation 13 | | Documentation 14 | | ExperienceReport 15 | | ExtendedExample 16 | | ForumPost 17 | | FunctionalPearl 18 | | JournalPaper 19 | | LectureNotes 20 | | MastersThesis 21 | | MetaResource 22 | | QAWebsite 23 | | ResearchPaper 24 | | ResearchPaperLite 25 | | SourceCode 26 | | SurveyArticle 27 | | Textbook 28 | | VideoLecture 29 | deriving (Bounded, Enum, Eq, Ord, Read, Show) 30 | derivePersistField "ResourceType" 31 | 32 | -- Reuse instance ToMarkup Text 33 | instance ToMarkup ResourceType where 34 | toMarkup = toMarkup . descResourceType 35 | preEscapedToMarkup = toMarkup . descResourceType 36 | 37 | -- Describe a resource type in a short sentence. 38 | descResourceType :: ResourceType -> Text 39 | descResourceType BlogPost = "Blog post" 40 | descResourceType CommunitySite = "Community website" 41 | descResourceType Dissertation = "Dissertation" 42 | descResourceType Documentation = "Documentation" 43 | descResourceType ExperienceReport = "Experience report" 44 | descResourceType ExtendedExample = "Extended example/tutorial" 45 | descResourceType ForumPost = "Forum post (e.g. Reddit comment)" 46 | descResourceType FunctionalPearl = "Functional pearl" 47 | descResourceType JournalPaper = "Journal paper" 48 | descResourceType LectureNotes = "Lecture slides/notes" 49 | descResourceType MastersThesis = "Master's thesis" 50 | descResourceType MetaResource = "Meta-resource" 51 | descResourceType QAWebsite = "Q&A website" 52 | descResourceType ResearchPaper = "Research paper" 53 | descResourceType ResearchPaperLite = "Light research paper" 54 | descResourceType SourceCode = "Source code" 55 | descResourceType SurveyArticle = "Survey article" 56 | descResourceType Textbook = "Textbook" 57 | descResourceType VideoLecture = "Video lecture/presentation" 58 | 59 | shortDescResourceType :: ResourceType -> Text 60 | shortDescResourceType BlogPost = "blog post" 61 | shortDescResourceType CommunitySite = "community website" 62 | shortDescResourceType Dissertation = "dissertation" 63 | shortDescResourceType Documentation = "documentation" 64 | shortDescResourceType ExperienceReport = "experience report" 65 | shortDescResourceType ExtendedExample = "tutorial" 66 | shortDescResourceType ForumPost = "forum post" 67 | shortDescResourceType FunctionalPearl = "functional pearl" 68 | shortDescResourceType JournalPaper = "journal paper" 69 | shortDescResourceType LectureNotes = "lecture notes" 70 | shortDescResourceType MastersThesis = "thesis" 71 | shortDescResourceType MetaResource = "meta-resource" 72 | shortDescResourceType QAWebsite = "answer" 73 | shortDescResourceType ResearchPaper = "paper" 74 | shortDescResourceType ResearchPaperLite = "light paper" 75 | shortDescResourceType SurveyArticle = "survey" 76 | shortDescResourceType SourceCode = "source code" 77 | shortDescResourceType Textbook = "textbook" 78 | shortDescResourceType VideoLecture = "video" 79 | 80 | -- | IMPORTANT: keep in sync with shortReadResourceTypePlural! 81 | shortDescResourceTypePlural :: ResourceType -> Text 82 | shortDescResourceTypePlural BlogPost = "blog posts" 83 | shortDescResourceTypePlural CommunitySite = "community websites" 84 | shortDescResourceTypePlural Dissertation = "dissertations" 85 | shortDescResourceTypePlural Documentation = "documentations" 86 | shortDescResourceTypePlural ExperienceReport = "experience reports" 87 | shortDescResourceTypePlural ExtendedExample = "tutorials" 88 | shortDescResourceTypePlural ForumPost = "forum posts" 89 | shortDescResourceTypePlural FunctionalPearl = "functional pearls" 90 | shortDescResourceTypePlural JournalPaper = "journal papers" 91 | shortDescResourceTypePlural LectureNotes = "lecture notes" 92 | shortDescResourceTypePlural MastersThesis = "theses" 93 | shortDescResourceTypePlural MetaResource = "meta-resources" 94 | shortDescResourceTypePlural QAWebsite = "answers" 95 | shortDescResourceTypePlural ResearchPaper = "research papers" 96 | shortDescResourceTypePlural ResearchPaperLite = "light research papers" 97 | shortDescResourceTypePlural SurveyArticle = "surveys" 98 | shortDescResourceTypePlural SourceCode = "source c0dez" 99 | shortDescResourceTypePlural Textbook = "textbooks" 100 | shortDescResourceTypePlural VideoLecture = "videos" 101 | 102 | -- | IMPORTANT: keep in sync with shortDescResourceTypePlural! 103 | shortReadResourceTypePlural :: Text -> Maybe ResourceType 104 | shortReadResourceTypePlural "blog posts" = Just BlogPost 105 | shortReadResourceTypePlural "community websites" = Just CommunitySite 106 | shortReadResourceTypePlural "dissertations" = Just Dissertation 107 | shortReadResourceTypePlural "documentations" = Just Documentation 108 | shortReadResourceTypePlural "experience reports" = Just ExperienceReport 109 | shortReadResourceTypePlural "tutorials" = Just ExtendedExample 110 | shortReadResourceTypePlural "forum posts" = Just ForumPost 111 | shortReadResourceTypePlural "functional pearls" = Just FunctionalPearl 112 | shortReadResourceTypePlural "journal papers" = Just JournalPaper 113 | shortReadResourceTypePlural "lecture notes" = Just LectureNotes 114 | shortReadResourceTypePlural "theses" = Just MastersThesis 115 | shortReadResourceTypePlural "meta-resources" = Just MetaResource 116 | shortReadResourceTypePlural "answers" = Just QAWebsite 117 | shortReadResourceTypePlural "research papers" = Just ResearchPaper 118 | shortReadResourceTypePlural "light research papers" = Just ResearchPaperLite 119 | shortReadResourceTypePlural "surveys" = Just SurveyArticle 120 | shortReadResourceTypePlural "source c0dez" = Just SourceCode 121 | shortReadResourceTypePlural "textbooks" = Just Textbook 122 | shortReadResourceTypePlural "videos" = Just VideoLecture 123 | shortReadResourceTypePlural _ = Nothing 124 | -------------------------------------------------------------------------------- /src/Model/ResourceEdit.hs: -------------------------------------------------------------------------------- 1 | module Model.ResourceEdit 2 | ( fetchAllEditAddCollectionsDB 3 | , fetchAllEditAddTagsDB 4 | , fetchAllEditAuthorsDB 5 | , fetchAllEditPublishedDB 6 | , fetchAllEditRemoveCollectionsDB 7 | , fetchAllEditRemoveTagsDB 8 | , fetchAllEditTitlesDB 9 | , fetchAllEditTypesDB 10 | , fetchEditAddCollectionsDB 11 | , fetchEditAddTagsDB 12 | , fetchEditAuthorsDB 13 | , fetchEditPublishedDB 14 | , fetchEditRemoveCollectionsDB 15 | , fetchEditRemoveTagsDB 16 | , fetchEditTitlesDB 17 | , fetchEditTypesDB 18 | , fetchNumRequestedEditsDB 19 | ) where 20 | 21 | import Import 22 | 23 | import qualified Data.Foldable as F 24 | import qualified Data.Map as M 25 | import Database.Esqueleto 26 | import Data.Monoid (Sum(..), getSum) 27 | 28 | fetchEditDB 29 | :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) 30 | => EntityField val ResourceId 31 | -> UserId 32 | -> YesodDB App (Map (Entity Resource) [Entity val]) 33 | fetchEditDB resIdField uid = fmap makeEditMap $ 34 | select $ 35 | from $ \(u `InnerJoin` r `InnerJoin` e) -> do 36 | on (u^.UserId ==. r^.ResourceUserId) 37 | on (r^.ResourceId ==. e^.resIdField) 38 | where_ (u^.UserId ==. val uid) 39 | return (r,e) 40 | 41 | fetchAllEditsDB 42 | :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) 43 | => EntityField val ResourceId 44 | -> YesodDB App (Map (Entity Resource) [Entity val]) 45 | fetchAllEditsDB resIdField = fmap makeEditMap $ 46 | select $ 47 | from $ \(r `InnerJoin` e) -> do 48 | on (r^.ResourceId ==. e^.resIdField) 49 | return (r,e) 50 | 51 | -- Not quite M.fromListWith, but close. 52 | makeEditMap :: Ord k => [(k,a)] -> Map k [a] 53 | makeEditMap = foldr (\(k,a) -> M.insertWith (++) k [a]) M.empty 54 | 55 | fetchEditAddCollectionsDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditAddCollection]) 56 | fetchEditAddTagsDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditAddTag]) 57 | fetchEditAuthorsDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditAuthors]) 58 | fetchEditPublishedDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditPublished]) 59 | fetchEditRemoveCollectionsDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditRemoveCollection]) 60 | fetchEditRemoveTagsDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditRemoveTag]) 61 | fetchEditTitlesDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditTitle]) 62 | fetchEditTypesDB :: UserId -> YesodDB App (Map (Entity Resource) [Entity EditType]) 63 | 64 | fetchEditAddCollectionsDB = fetchEditDB EditAddCollectionResId 65 | fetchEditAddTagsDB = fetchEditDB EditAddTagResId 66 | fetchEditAuthorsDB = fetchEditDB EditAuthorsResId 67 | fetchEditPublishedDB = fetchEditDB EditPublishedResId 68 | fetchEditRemoveCollectionsDB = fetchEditDB EditRemoveCollectionResId 69 | fetchEditRemoveTagsDB = fetchEditDB EditRemoveTagResId 70 | fetchEditTitlesDB = fetchEditDB EditTitleResId 71 | fetchEditTypesDB = fetchEditDB EditTypeResId 72 | 73 | fetchAllEditAddCollectionsDB :: YesodDB App (Map (Entity Resource) [Entity EditAddCollection]) 74 | fetchAllEditAddTagsDB :: YesodDB App (Map (Entity Resource) [Entity EditAddTag]) 75 | fetchAllEditAuthorsDB :: YesodDB App (Map (Entity Resource) [Entity EditAuthors]) 76 | fetchAllEditPublishedDB :: YesodDB App (Map (Entity Resource) [Entity EditPublished]) 77 | fetchAllEditRemoveCollectionsDB :: YesodDB App (Map (Entity Resource) [Entity EditRemoveCollection]) 78 | fetchAllEditRemoveTagsDB :: YesodDB App (Map (Entity Resource) [Entity EditRemoveTag]) 79 | fetchAllEditTitlesDB :: YesodDB App (Map (Entity Resource) [Entity EditTitle]) 80 | fetchAllEditTypesDB :: YesodDB App (Map (Entity Resource) [Entity EditType]) 81 | 82 | fetchAllEditAddCollectionsDB = fetchAllEditsDB EditAddCollectionResId 83 | fetchAllEditAddTagsDB = fetchAllEditsDB EditAddTagResId 84 | fetchAllEditAuthorsDB = fetchAllEditsDB EditAuthorsResId 85 | fetchAllEditPublishedDB = fetchAllEditsDB EditPublishedResId 86 | fetchAllEditRemoveCollectionsDB = fetchAllEditsDB EditRemoveCollectionResId 87 | fetchAllEditRemoveTagsDB = fetchAllEditsDB EditRemoveTagResId 88 | fetchAllEditTitlesDB = fetchAllEditsDB EditTitleResId 89 | fetchAllEditTypesDB = fetchAllEditsDB EditTypeResId 90 | 91 | -- TODO: Should probably select count(*) ? 92 | fetchNumRequestedEditsDB :: UserId -> YesodDB App Int 93 | fetchNumRequestedEditsDB uid = getSum . mconcat <$> 94 | sequence 95 | [ adjust <$> fetchEditAddCollectionsDB uid 96 | , adjust <$> fetchEditAddTagsDB uid 97 | , adjust <$> fetchEditAuthorsDB uid 98 | , adjust <$> fetchEditPublishedDB uid 99 | , adjust <$> fetchEditRemoveCollectionsDB uid 100 | , adjust <$> fetchEditRemoveTagsDB uid 101 | , adjust <$> fetchEditTitlesDB uid 102 | , adjust <$> fetchEditTypesDB uid 103 | ] 104 | where 105 | adjust :: Map k [a] -> Sum Int 106 | adjust = F.foldMap (Sum . length) 107 | -------------------------------------------------------------------------------- /src/Model/Tag.hs: -------------------------------------------------------------------------------- 1 | module Model.Tag where 2 | 3 | import Import 4 | 5 | import Model.Resource 6 | 7 | -- | Get all tags. 8 | fetchAllTagsDB :: YesodDB App [Entity Tag] 9 | fetchAllTagsDB = selectList [] [] 10 | 11 | -- | Get a map of TagId to the number of Resources with that tag. 12 | fetchTagCountsDB :: YesodDB App (Map TagId Int) 13 | fetchTagCountsDB = fetchResourceFieldCountsDB ResourceTagTagId 14 | 15 | -- | Get the year range of all Resources of with a specific Tag. If none of the 16 | -- Resources with that Tag have any published year, then the Tag will not exist 17 | -- in the returned map. 18 | fetchTagYearRangesDB :: YesodDB App (Map TagId (Int, Int)) 19 | fetchTagYearRangesDB = fetchResourceFieldYearRangesDB ResourceTagResId ResourceTagTagId 20 | -------------------------------------------------------------------------------- /src/Model/User.hs: -------------------------------------------------------------------------------- 1 | module Model.User 2 | ( fetchGrokkedCountsByAuthorDB 3 | , fetchGrokkedCountsByCollectionDB 4 | , fetchGrokkedCountsByTagDB 5 | , fetchGrokkedCountsByTypeDB 6 | , fetchGrokkedResourceIdsInDB 7 | , fetchNumSubmittedResourcesDB 8 | , fetchNumGrokkedResourcesDB 9 | , fetchSubmittedResourcesDB 10 | , isAdministratorDB 11 | , thisUserHasAuthorityOverDB 12 | , updateUserDisplayNameDB 13 | , userHasAuthorityOverDB 14 | ) where 15 | 16 | import Import 17 | 18 | import Model.List 19 | import Model.Resource 20 | 21 | import Database.Esqueleto 22 | import qualified Data.Map as M 23 | 24 | -- | Get the number of Resources this User has grokked, grouped by Author/Collection/Tag/Type. 25 | fetchGrokkedCountsByAuthorDB :: UserId -> YesodDB App (Map AuthorId Int) 26 | fetchGrokkedCountsByCollectionDB :: UserId -> YesodDB App (Map CollectionId Int) 27 | fetchGrokkedCountsByTagDB :: UserId -> YesodDB App (Map TagId Int) 28 | fetchGrokkedCountsByTypeDB :: UserId -> YesodDB App (Map ResourceType Int) 29 | fetchGrokkedCountsByAuthorDB = fetchGrokkedCountsByFieldDB ResAuthorResId ResAuthorAuthId 30 | fetchGrokkedCountsByCollectionDB = fetchGrokkedCountsByFieldDB ResCollectionResId ResCollectionColId 31 | fetchGrokkedCountsByTagDB = fetchGrokkedCountsByFieldDB ResourceTagResId ResourceTagTagId 32 | fetchGrokkedCountsByTypeDB = fetchGrokkedCountsByFieldDB ResourceId ResourceType 33 | 34 | fetchGrokkedCountsByFieldDB :: (PersistEntity entity, PersistEntityBackend entity ~ SqlBackend, 35 | PersistField key, Ord key) 36 | => EntityField entity ResourceId 37 | -> EntityField entity key 38 | -> UserId 39 | -> YesodDB App (Map key Int) 40 | fetchGrokkedCountsByFieldDB res_id_field key user_id = 41 | fetchGrokkedListIdDB >>= \case 42 | Nothing -> return mempty 43 | Just grokked_list_id -> fmap (M.fromList . map fromValue) $ 44 | select $ 45 | from $ \(table `InnerJoin` li) -> do 46 | on (table^.res_id_field ==. li^.ListItemResId) 47 | where_ $ 48 | li^.ListItemListId ==. val grokked_list_id &&. 49 | li^.ListItemUserId ==. val user_id 50 | groupBy (table^.key) 51 | return (table^.key, countRows :: SqlExpr (Value Int)) 52 | 53 | -- | Given a list of Resources, return only those grokked by the given User. 54 | fetchGrokkedResourceIdsInDB :: UserId -> [ResourceId] -> YesodDB App [ResourceId] 55 | fetchGrokkedResourceIdsInDB user_id res_ids = 56 | fetchGrokkedListIdDB >>= \case 57 | Nothing -> return [] 58 | Just grokked_list_id -> fmap (map unValue) $ 59 | select $ 60 | from $ \li -> do 61 | where_ $ 62 | li^.ListItemListId ==. val grokked_list_id &&. 63 | li^.ListItemUserId ==. val user_id &&. 64 | li^.ListItemResId `in_` valList res_ids 65 | return (li^.ListItemResId) 66 | 67 | fetchSubmittedResourcesDB :: UserId -> YesodDB App [Entity Resource] 68 | fetchSubmittedResourcesDB uid = 69 | select $ 70 | from $ \(u `InnerJoin` r) -> do 71 | on (u^.UserId ==. r^.ResourceUserId) 72 | where_ (u^.UserId ==. val uid) 73 | return r 74 | 75 | fetchNumSubmittedResourcesDB :: UserId -> YesodDB App Int 76 | fetchNumSubmittedResourcesDB user_id = fmap (\[Value n] -> n) $ 77 | select $ 78 | from $ \(u `InnerJoin` r) -> do 79 | on (u^.UserId ==. r^.ResourceUserId) 80 | where_ (u^.UserId ==. val user_id) 81 | return countRows 82 | 83 | fetchNumGrokkedResourcesDB :: UserId -> YesodDB App Int 84 | fetchNumGrokkedResourcesDB user_id = fetchGrokkedListIdDB >>= \case 85 | Nothing -> return 0 86 | Just grokked_list_id -> fmap (\[Value n] -> n) $ 87 | select $ 88 | from $ \li -> do 89 | where_ $ 90 | li^.ListItemListId ==. val grokked_list_id &&. 91 | li^.ListItemUserId ==. val user_id 92 | return countRows 93 | 94 | isAdministratorDB :: UserId -> YesodDB App Bool 95 | isAdministratorDB = fmap (maybe False userIsAdministrator) . get 96 | 97 | updateUserDisplayNameDB :: UserId -> Text -> YesodDB App () 98 | updateUserDisplayNameDB uid displayName = 99 | update $ \u -> do 100 | set u [UserDisplayName =. val displayName] 101 | where_ (u^.UserId ==. val uid) 102 | 103 | -- 'bully' has authority over 'nerd' if 'bully' is an administrator, 104 | -- or if 'bully' and 'nerd' are the same user. 105 | -- 106 | -- Assumes that 'bully' is an actual user id, not from a URL. 107 | userHasAuthorityOverDB :: UserId -> UserId -> YesodDB App Bool 108 | userHasAuthorityOverDB bully nerd = do 109 | isAdmin <- userIsAdministrator <$> getJust bully 110 | return $ 111 | if isAdmin 112 | then True 113 | else (bully == nerd) 114 | 115 | -- | Like userHasAuthorityOverDB, but uses the current user ('this' user) as the 116 | -- first argument. 117 | thisUserHasAuthorityOverDB :: UserId -> Handler Bool 118 | thisUserHasAuthorityOverDB nerd = maybeAuthId >>= \case 119 | Nothing -> return False 120 | Just bully -> runDB (userHasAuthorityOverDB bully nerd) 121 | -------------------------------------------------------------------------------- /src/Model/Utils.hs: -------------------------------------------------------------------------------- 1 | module Model.Utils where 2 | 3 | import Import 4 | 5 | import qualified Data.Map as M 6 | import qualified Data.Text as T 7 | 8 | orderAlphabeticIgnoreCase :: (a -> Text) -> a -> a -> Ordering 9 | orderAlphabeticIgnoreCase f x y = T.toLower (f x) `compare` T.toLower (f y) 10 | 11 | -- | Order by lowest-count-first. Secondary key: alphabetical. 12 | orderCountUp :: Ord b => (a -> Text) -> (a -> b) -> Map b Int -> a -> a -> Ordering 13 | orderCountUp text_func key_func count_map x y = compareCounts <> orderAlphabeticIgnoreCase text_func x y 14 | where 15 | compareCounts = case (M.lookup (key_func x) count_map, M.lookup (key_func y) count_map) of 16 | (Just n, Just m) -> compare n m 17 | (Just _, Nothing) -> GT -- Nothing means 0 18 | (Nothing, Just _) -> LT 19 | _ -> EQ 20 | 21 | -- | Order by highest-count-first. Secondary key: alphabetical. 22 | orderCountDown :: Ord b => (a -> Text) -> (a -> b) -> Map b Int -> a -> a -> Ordering 23 | orderCountDown text_func key_func count_map x y = compareCounts <> orderAlphabeticIgnoreCase text_func x y 24 | where 25 | compareCounts = case (M.lookup (key_func x) count_map, M.lookup (key_func y) count_map) of 26 | (Just n, Just m) -> compare m n 27 | (Just _, Nothing) -> LT -- Nothing means 0 28 | (Nothing, Just _) -> GT 29 | _ -> EQ 30 | 31 | -- | Order by earliest-first-year-first (e.g. "1999-2014" comes before "2000-2001".) 32 | -- Secondary key: alphabetical. 33 | orderYearUp :: Ord b => (a -> Text) -> (a -> b) -> Map b (Int, Int) -> a -> a -> Ordering 34 | orderYearUp text_func key_func year_ranges_map x y = compareEarliest <> orderAlphabeticIgnoreCase text_func x y 35 | where 36 | compareEarliest = case (M.lookup (key_func x) year_ranges_map, M.lookup (key_func y) year_ranges_map) of 37 | (Just (n, _), Just (m, _)) -> compare n m 38 | (Just _, Nothing) -> LT -- Nothing means no year, so put it at the bottom 39 | (Nothing, Just _) -> GT 40 | _ -> EQ 41 | 42 | -- | Order by latest-last-year-first (e.g. "1999-2014" comes before "2000-2001".) 43 | -- Secondary key: alphabetical. 44 | orderYearDown :: Ord b => (a -> Text) -> (a -> b) -> Map b (Int, Int) -> a -> a -> Ordering 45 | orderYearDown text_func key_func year_ranges_map x y = compareLatest <> orderAlphabeticIgnoreCase text_func x y 46 | where 47 | compareLatest = case (M.lookup (key_func x) year_ranges_map, M.lookup (key_func y) year_ranges_map) of 48 | (Just (_, n), Just (_, m)) -> compare m n 49 | (Just _, Nothing) -> LT -- Nothing means no year, so put it at the bottom 50 | (Nothing, Just _) -> GT 51 | _ -> EQ 52 | -------------------------------------------------------------------------------- /src/Settings.hs: -------------------------------------------------------------------------------- 1 | -- | Settings are centralized, as much as possible, into this file. This 2 | -- includes database connection settings, static file locations, etc. 3 | -- In addition, you can configure a number of different aspects of Yesod 4 | -- by overriding methods in the Yesod typeclass. That instance is 5 | -- declared in the Foundation.hs file. 6 | module Settings where 7 | 8 | import ClassyPrelude.Yesod 9 | import Control.Exception (throw) 10 | import Data.Aeson (Result (..), fromJSON, withObject, (.!=), 11 | (.:?)) 12 | import Data.FileEmbed (embedFile) 13 | import Data.Yaml (decodeEither') 14 | import Database.Persist.Sqlite (SqliteConf) 15 | import Language.Haskell.TH.Syntax (Exp, Name, Q) 16 | import Network.Wai.Handler.Warp (HostPreference) 17 | import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) 18 | import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, 19 | widgetFileReload) 20 | 21 | -- | Runtime settings to configure this application. These settings can be 22 | -- loaded from various sources: defaults, environment variables, config files, 23 | -- theoretically even a database. 24 | data AppSettings = AppSettings 25 | { appStaticDir :: String 26 | -- ^ Directory from which to serve static files. 27 | , appDatabaseConf :: SqliteConf 28 | -- ^ Configuration settings for accessing the database. 29 | , appRoot :: Text 30 | -- ^ Base for all generated URLs. 31 | , appHost :: HostPreference 32 | -- ^ Host/interface the server should bind to. 33 | , appPort :: Int 34 | -- ^ Port to listen on 35 | , appIpFromHeader :: Bool 36 | -- ^ Get the IP address from the header when logging. Useful when sitting 37 | -- behind a reverse proxy. 38 | , appOauthClientSecret :: Text 39 | -- ^ Oauth2 client secret 40 | 41 | , appDetailedRequestLogging :: Bool 42 | -- ^ Use detailed request logging system 43 | , appShouldLogAll :: Bool 44 | -- ^ Should all log messages be displayed? 45 | , appReloadTemplates :: Bool 46 | -- ^ Use the reload version of templates 47 | , appMutableStatic :: Bool 48 | -- ^ Assume that files in the static dir may change after compilation 49 | , appSkipCombining :: Bool 50 | -- ^ Perform no stylesheet/script combining 51 | 52 | -- Example app-specific configuration values. 53 | , appCopyright :: Text 54 | -- ^ Copyright text to appear in the footer of the page 55 | , appAnalytics :: Maybe Text 56 | -- ^ Google Analytics code 57 | } 58 | 59 | instance FromJSON AppSettings where 60 | parseJSON = withObject "AppSettings" $ \o -> do 61 | let defaultDev = 62 | #if DEVELOPMENT 63 | True 64 | #else 65 | False 66 | #endif 67 | appStaticDir <- o .: "static-dir" 68 | appDatabaseConf <- o .: "database" 69 | appRoot <- o .: "approot" 70 | appHost <- fromString <$> o .: "host" 71 | appPort <- o .: "port" 72 | appIpFromHeader <- o .: "ip-from-header" 73 | appOauthClientSecret <- o .: "oauth-client-secret" 74 | 75 | appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev 76 | appShouldLogAll <- o .:? "should-log-all" .!= defaultDev 77 | appReloadTemplates <- o .:? "reload-templates" .!= defaultDev 78 | appMutableStatic <- o .:? "mutable-static" .!= defaultDev 79 | appSkipCombining <- o .:? "skip-combining" .!= defaultDev 80 | 81 | appCopyright <- o .: "copyright" 82 | appAnalytics <- o .:? "analytics" 83 | 84 | return AppSettings {..} 85 | 86 | -- | Settings for 'widgetFile', such as which template languages to support and 87 | -- default Hamlet settings. 88 | -- 89 | -- For more information on modifying behavior, see: 90 | -- 91 | -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile 92 | widgetFileSettings :: WidgetFileSettings 93 | widgetFileSettings = def 94 | 95 | -- | How static files should be combined. 96 | combineSettings :: CombineSettings 97 | combineSettings = def 98 | 99 | -- The rest of this file contains settings which rarely need changing by a 100 | -- user. 101 | 102 | widgetFile :: String -> Q Exp 103 | widgetFile = (if appReloadTemplates compileTimeAppSettings 104 | then widgetFileReload 105 | else widgetFileNoReload) 106 | widgetFileSettings 107 | 108 | -- | Raw bytes at compile time of @config/settings.yml@ 109 | configSettingsYmlBS :: ByteString 110 | configSettingsYmlBS = $(embedFile configSettingsYml) 111 | 112 | -- | @config/settings.yml@, parsed to a @Value@. 113 | configSettingsYmlValue :: Value 114 | configSettingsYmlValue = either throw id $ decodeEither' configSettingsYmlBS 115 | 116 | -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. 117 | compileTimeAppSettings :: AppSettings 118 | compileTimeAppSettings = 119 | case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of 120 | Error e -> error e 121 | Success settings -> settings 122 | 123 | -- The following two functions can be used to combine multiple CSS or JS files 124 | -- at compile time to decrease the number of http requests. 125 | -- Sample usage (inside a Widget): 126 | -- 127 | -- > $(combineStylesheets 'StaticR [style1_css, style2_css]) 128 | 129 | combineStylesheets :: Name -> [Route Static] -> Q Exp 130 | combineStylesheets = combineStylesheets' 131 | (appSkipCombining compileTimeAppSettings) 132 | combineSettings 133 | 134 | combineScripts :: Name -> [Route Static] -> Q Exp 135 | combineScripts = combineScripts' 136 | (appSkipCombining compileTimeAppSettings) 137 | combineSettings 138 | -------------------------------------------------------------------------------- /src/Settings/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | module Settings.StaticFiles where 2 | 3 | import Settings (appStaticDir, compileTimeAppSettings) 4 | import Yesod.Static (staticFiles) 5 | 6 | -- This generates easy references to files in the static directory at compile time, 7 | -- giving you compile-time verification that referenced files exist. 8 | -- Warning: any files added to your static directory during run-time can't be 9 | -- accessed this way. You'll have to use their FilePath or URL to access them. 10 | -- 11 | -- For example, to refer to @static/js/script.js@ via an identifier, you'd use: 12 | -- 13 | -- js_script_js 14 | -- 15 | -- If the identifier is not available, you may use: 16 | -- 17 | -- StaticFile ["js", "script.js"] [] 18 | staticFiles (appStaticDir compileTimeAppSettings) 19 | 20 | -------------------------------------------------------------------------------- /src/View/Browse.hs: -------------------------------------------------------------------------------- 1 | module View.Browse 2 | ( BrowseByLink(..) 3 | , browseBarWidget 4 | , pageWidget 5 | , pageWidgetEmbed 6 | , resourceListWidget 7 | , sortBarWidget 8 | , sortResBarWidget 9 | ) where 10 | 11 | import Import 12 | 13 | import Handler.Utils 14 | import Model.Browse 15 | import Model.Resource 16 | import Model.User 17 | 18 | import qualified Data.Map as M 19 | import qualified Data.Set as S 20 | import qualified Data.Text as T 21 | import Text.Cassius (cassiusFile) 22 | import Text.Julius (juliusFile) 23 | import Text.Hamlet (hamletFile) 24 | 25 | boldIfEq :: Eq a => a -> a -> Text 26 | boldIfEq x y | x == y = "bold" 27 | boldIfEq _ _ = "normal" 28 | 29 | browseBarWidget :: BrowseByLink -> Widget 30 | browseBarWidget browse_by_link = do 31 | [whamlet| 32 |
browse by: # 33 | author 34 | | 35 | tag 36 | | 37 | collection 38 | | 39 | type 40 | | 41 | list all 42 | |] 43 | topBarCSS 44 | toWidget [cassius| 45 | #br-auth 46 | font-weight: #{boldIfEq browse_by_link BrowseByAuthorLink} 47 | 48 | #br-coll 49 | font-weight: #{boldIfEq browse_by_link BrowseByCollectionLink} 50 | 51 | #br-res 52 | font-weight: #{boldIfEq browse_by_link BrowseByResourceLink} 53 | 54 | #br-tag 55 | font-weight: #{boldIfEq browse_by_link BrowseByTagLink} 56 | 57 | #br-type 58 | font-weight: #{boldIfEq browse_by_link BrowseByTypeLink} 59 | |] 60 | 61 | sortBarWidget :: Text -> SortBy -> Widget 62 | sortBarWidget text SortByAZ = do 63 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 64 | [whamlet| 65 |
sort #{text} by: # 66 | a-z 67 | | 68 | count# 69 | ▼ 70 | | 71 | year# 72 | ▼ 73 | |] 74 | topBarCSS 75 | toWidget [cassius| 76 | #so-az 77 | font-weight: bold 78 | |] 79 | sortBarWidget text SortByCountUp = do 80 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 81 | [whamlet| 82 |
sort #{text} by: # 83 | a-z 84 | | 85 | count# 86 | ▲ 87 | | 88 | year# 89 | ▼ 90 | |] 91 | topBarCSS 92 | toWidget [cassius| 93 | #so-count-down 94 | font-weight: bold 95 | |] 96 | sortBarWidget text SortByCountDown = do 97 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 98 | [whamlet| 99 |
sort #{text} by: # 100 | a-z 101 | | 102 | count# 103 | ▼ 104 | | 105 | year# 106 | ▼ 107 | |] 108 | topBarCSS 109 | toWidget [cassius| 110 | #so-count-up 111 | font-weight: bold 112 | |] 113 | sortBarWidget text SortByYearUp = do 114 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 115 | [whamlet| 116 |
sort #{text} by: # 117 | a-z 118 | | 119 | count# 120 | ▼ 121 | | 122 | year# 123 | ▲ 124 | |] 125 | topBarCSS 126 | toWidget [cassius| 127 | #so-year-down 128 | font-weight: bold 129 | |] 130 | sortBarWidget text SortByYearDown = do 131 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 132 | [whamlet| 133 |
sort #{text} by: # 134 | a-z 135 | | 136 | count# 137 | ▼ 138 | | 139 | year# 140 | ▼ 141 | |] 142 | topBarCSS 143 | toWidget [cassius| 144 | #so-year-up 145 | font-weight: bold 146 | |] 147 | sortBarWidget text SortByRecentlyAdded = do 148 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 149 | [whamlet| 150 |
sort #{text} by: # 151 | a-z 152 | | 153 | count# 154 | ▼ 155 | | 156 | year# 157 | ▼ 158 | |] 159 | topBarCSS 160 | toWidget [cassius| 161 | #so-recently-added 162 | font-weight: bold 163 | |] 164 | 165 | sortResBarWidget :: SortBy -> Widget 166 | sortResBarWidget SortByYearUp = do 167 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 168 | [whamlet| 169 |
sort resources by: # 170 | a-z 171 | | 172 | year# 173 | ▲ 174 | | 175 | recently added 176 | |] 177 | sortResBarCSS 178 | toWidget [cassius| 179 | #so-res-year-down 180 | font-weight: bold 181 | |] 182 | sortResBarWidget SortByYearDown = do 183 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 184 | [whamlet| 185 |
sort resources by: # 186 | a-z 187 | | 188 | year# 189 | ▼ 190 | | 191 | recently added 192 | |] 193 | sortResBarCSS 194 | toWidget [cassius| 195 | #so-res-year-up 196 | font-weight: bold 197 | |] 198 | sortResBarWidget SortByRecentlyAdded = do 199 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 200 | [whamlet| 201 |
sort resources by: # 202 | a-z 203 | | 204 | year# 205 | ▼ 206 | | 207 | recently added 208 | |] 209 | sortResBarCSS 210 | toWidget [cassius| 211 | #so-res-recently-added 212 | font-weight: bold 213 | |] 214 | sortResBarWidget _ = do 215 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 216 | [whamlet| 217 |
sort resources by: # 218 | a-z 219 | | 220 | year# 221 | ▼ 222 | | 223 | recently added 224 | |] 225 | sortResBarCSS 226 | toWidget [cassius| 227 | #so-res-az 228 | font-weight: bold 229 | |] 230 | 231 | -- | CSS that applies to browse/sort/sort resources bars. 232 | topBarCSS :: Widget 233 | topBarCSS = toWidget 234 | [cassius| 235 | .bar 236 | font-size: 1.1em 237 | font-variant: small-caps 238 | height: 1.1em 239 | line-height: 1.1em 240 | 241 | .bar-link 242 | color: #069 243 | 244 | a.bar-link:hover 245 | text-decoration: none 246 | 247 | .arr 248 | font-size: 0.7em 249 | |] 250 | 251 | 252 | -- | CSS that applies to all sort resource bars (topBarCSS + bottom margin + bottom border) 253 | sortResBarCSS :: Widget 254 | sortResBarCSS = do 255 | topBarCSS 256 | toWidget [cassius| 257 | .sort-res-bar 258 | border-bottom: 1px solid black 259 | margin-bottom: 4px 260 | |] 261 | 262 | resourceListWidget :: [Entity Resource] -> Widget 263 | resourceListWidget resources = do 264 | let resource_ids = map entityKey resources 265 | 266 | authorsMap <- handlerToWidget $ runDB (fetchResourceAuthorsInDB resource_ids) 267 | 268 | (is_logged_in, grokked) <- handlerToWidget $ 269 | maybeAuthId >>= \case 270 | Nothing -> return (False, mempty) 271 | Just user_id -> runDB $ (,) 272 | <$> pure True 273 | <*> (S.fromList <$> fetchGrokkedResourceIdsInDB user_id resource_ids) 274 | 275 | toWidget $(hamletFile "templates/resource-list.hamlet") 276 | toWidget $(cassiusFile "templates/resource-list.cassius") 277 | if is_logged_in 278 | then toWidget $(juliusFile "templates/resource-list-logged-in.julius") 279 | else toWidget $(juliusFile "templates/resource-list-not-logged-in.julius") 280 | 281 | pageWidget :: Maybe Int64 -> Maybe Int64 -> Widget 282 | pageWidget mprev mnext = do 283 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 284 | [whamlet| 285 | $maybe prev <- mprev 286 | Prev 287 | $maybe next <- mnext 288 | Next 289 | |] 290 | 291 | pageWidgetEmbed :: Maybe Int64 -> Maybe Int64 -> Widget 292 | pageWidgetEmbed mprev mnext = do 293 | (route, params) <- handlerToWidget getCurrentRouteWithGetParams 294 | case mprev of 295 | Nothing -> pure () 296 | Just prev -> do 297 | [whamlet| 298 | $maybe _ <- mprev 299 | Prev 300 | |] 301 | toWidget [julius| 302 | $(document).ready(function() { 303 | $('.prev-page').click(function() { 304 | $(this).parent().load('@?{(route, addGetParam ("page", T.pack (show prev)) params)}'); 305 | }); 306 | }); 307 | |] 308 | case mnext of 309 | Nothing -> pure () 310 | Just next -> do 311 | [whamlet| 312 | $maybe _ <- mnext 313 | Next 314 | |] 315 | toWidget [julius| 316 | $(document).ready(function() { 317 | $('.next-page').click(function() { 318 | $(this).parent().load('@?{(route, addGetParam ("page", T.pack (show next)) params)}'); 319 | }); 320 | }); 321 | |] 322 | toWidget [cassius| 323 | a.prev-page:hover 324 | cursor: pointer 325 | 326 | a.next-page:hover 327 | cursor: pointer 328 | |] 329 | -------------------------------------------------------------------------------- /src/View/Feed.hs: -------------------------------------------------------------------------------- 1 | module View.Feed 2 | ( atomFeedWidget 3 | , rssFeedWidget 4 | ) where 5 | 6 | import Import 7 | 8 | import Database.Esqueleto 9 | import qualified Data.Map as M 10 | import qualified Data.Text as T 11 | import Text.Atom.Feed (Entry(..), Link(..), feedEntries, txtToString) 12 | import qualified Text.Atom.Feed as Atom 13 | import Text.Blaze (ToMarkup) 14 | import Text.RSS.Syntax (RSS(..), RSSChannel(..), RSSItem(..)) 15 | 16 | makeUrlToResIdMap :: YesodDB App (Map Text ResourceId) 17 | makeUrlToResIdMap = fmap (M.fromList . map fromValue) sel 18 | where 19 | sel :: YesodDB App [(Value Text, Value ResourceId)] 20 | sel = select $ 21 | from $ \r -> 22 | return (r^.ResourceUrl, r^.ResourceId) 23 | 24 | -- | Get an Entry's rel="alternate" link (no rel implies rel="alternate"). 25 | -- There can be multiple alternate links, each with a different 26 | -- type/hreflang combination, but we're just being dumb and grabbing 27 | -- the first one. 28 | getEntryAlternateLink :: Atom.Entry -> Atom.Link 29 | getEntryAlternateLink = go . entryLinks 30 | where 31 | go (x@(Atom.Link _ Nothing _ _ _ _ _ _):_) = x 32 | go (x@(Atom.Link _ (Just (Right "alternate")) _ _ _ _ _ _):_) = x 33 | go (_:xs) = go xs 34 | go [] = error "RFC 4287 violation, rel=alternate link missing" 35 | 36 | atomFeedWidget :: Text -> Atom.Feed -> Widget 37 | atomFeedWidget feed_url Atom.Feed{..} = do 38 | url_to_res_id_map <- handlerToWidget $ runDB makeUrlToResIdMap 39 | feedHeader (txtToString feedTitle) feed_url 40 | [whamlet| 41 |
42 | $forall entry <- feedEntries 43 | $with link_uri <- T.pack $ linkHref (getEntryAlternateLink entry) 44 |
45 | $maybe res_id <- M.lookup link_uri url_to_res_id_map 46 | #{txtToString $ entryTitle entry} 47 | $nothing 48 | #{txtToString $ entryTitle entry} 49 | |] 50 | feedCassius 51 | 52 | rssFeedWidget :: Text -> RSS -> Widget 53 | rssFeedWidget feed_url RSS{..} = do 54 | url_to_res_id_map <- handlerToWidget $ runDB makeUrlToResIdMap 55 | feedHeader (rssTitle rssChannel) feed_url 56 | [whamlet| 57 |
58 | $forall item <- rssItems rssChannel 59 | $with title <- fromMaybe "(no title)" (rssItemTitle item) 60 | $maybe link <- T.pack <$> rssItemLink item 61 |
62 | $maybe res_id <- M.lookup link url_to_res_id_map 63 | #{title} 64 | $nothing 65 | #{title} 66 | |] 67 | feedCassius 68 | 69 | feedHeader :: (ToMarkup a, ToMarkup b) => a -> b -> Widget 70 | feedHeader title url = do 71 | [whamlet| 72 |
73 | Back 74 |
#{title} (#{url}) 75 | |] 76 | toWidget [cassius| 77 | .header a 78 | display: inline-block 79 | margin-bottom: 5px 80 | 81 | .header 82 | border-bottom: 1px solid black 83 | font-weight: bold 84 | margin-bottom: 5px 85 | |] 86 | 87 | feedCassius :: Widget 88 | feedCassius = 89 | toWidget [cassius| 90 | .exists 91 | color: gray 92 | 93 | .not-exists 94 | font-weight: bold 95 | 96 | .entry 97 | font-size: 1.2em 98 | line-height: 1.3em 99 | padding-left: 5px 100 | 101 | .entry a 102 | display: block 103 | padding-left: 5px 104 | text-decoration: none 105 | 106 | .entry a:hover 107 | background-color: #eee 108 | 109 | .entry a.exists:hover 110 | color: gray 111 | 112 | .entry a.not-exists:hover 113 | color: black 114 | 115 | |] 116 | -------------------------------------------------------------------------------- /src/View/Navbar.hs: -------------------------------------------------------------------------------- 1 | module View.Navbar where 2 | 3 | import Import 4 | 5 | navbarWidget :: Widget 6 | navbarWidget = do 7 | muid <- handlerToWidget maybeAuthId 8 | $(widgetFile "navbar") 9 | -------------------------------------------------------------------------------- /src/View/Resource.hs: -------------------------------------------------------------------------------- 1 | module View.Resource 2 | ( editResourceForm 3 | , editResourceFormWidget 4 | , resourceForm 5 | , resourceInfoWidget 6 | ) where 7 | 8 | import Import 9 | 10 | import Handler.Utils (prettyAgo) 11 | import Model.Resource 12 | import Yesod.Form.Types.Extra (commaSepTextField, mapField) 13 | 14 | import Data.List (nub) 15 | import qualified Data.Text as T 16 | import Yesod.Form.Bootstrap3 -- (renderBootstrap3) 17 | 18 | -- Crappy type synonyms, trying not to clash with models. Unexported. 19 | type AuthorNameText = Text 20 | type CollectionNameText = Text 21 | type TagNameText = Text 22 | type Title = Text 23 | type YearPublished = Int 24 | 25 | -- | Form for editing a resource. Notably does not include the URL. 26 | editResourceForm :: Maybe Title 27 | -> Maybe [AuthorNameText] 28 | -> Maybe (Maybe YearPublished) 29 | -> Maybe ResourceType 30 | -> Maybe [TagNameText] 31 | -> Maybe [CollectionNameText] 32 | -> Form (Title, [AuthorNameText], Maybe YearPublished, ResourceType, [TagNameText], [CollectionNameText]) 33 | editResourceForm title authors published typ tags colls = renderDivs $ (,,,,,) 34 | <$> resTitleForm title 35 | <*> resAuthorsForm authors 36 | <*> resPublishedForm published 37 | <*> resTypeForm typ 38 | <*> resTagsForm tags 39 | <*> resCollectionsForm colls 40 | 41 | editResourceFormWidget :: ResourceId 42 | -> Maybe Title 43 | -> Maybe [AuthorNameText] 44 | -> Maybe (Maybe YearPublished) 45 | -> Maybe ResourceType 46 | -> Maybe [TagNameText] 47 | -> Maybe [CollectionNameText] 48 | -> Widget 49 | editResourceFormWidget res_id title authors published typ tags colls = do 50 | (widget, enctype) <- handlerToWidget . generateFormPost $ 51 | editResourceForm title authors published typ tags colls 52 | 53 | [whamlet| 54 |
55 | ^{widget} 56 | 57 | |] 58 | 59 | -- | A single form to input a Resource. 60 | resourceForm :: UserId -> Form ( Title 61 | , Text -- ^ URL. 62 | , [AuthorNameText] 63 | , Maybe YearPublished 64 | , ResourceType 65 | , [TagNameText] 66 | , [CollectionNameText] 67 | , UserId -- ^ Poster. 68 | , UTCTime -- ^ Timestamp. 69 | ) 70 | resourceForm uid = renderBootstrap3 BootstrapInlineForm $ (,,,,,,,,) 71 | <$> resTitleForm Nothing 72 | <*> resUrlForm Nothing 73 | <*> resAuthorsForm Nothing 74 | <*> resPublishedForm Nothing 75 | <*> resTypeForm Nothing 76 | <*> resTagsForm Nothing 77 | <*> resCollectionsForm Nothing 78 | <*> pure uid 79 | <*> lift (liftIO getCurrentTime) 80 | <* bootstrapSubmit ("Submit" :: BootstrapSubmit Text) 81 | 82 | resTitleForm :: Maybe Title -> AForm Handler Title 83 | resTitleForm = areq textField "Title" 84 | 85 | resUrlForm :: Maybe Text -> AForm Handler Text 86 | resUrlForm = areq urlField ("Url" {fsAttrs = [("placeholder", "http://")]}) 87 | 88 | resAuthorsForm :: Maybe [AuthorNameText] -> AForm Handler [AuthorNameText] 89 | resAuthorsForm = fmap (fromMaybe []) . aopt field "Author(s) (optional, comma separated)" . fmap Just 90 | where 91 | field :: Field Handler [AuthorNameText] 92 | field = mapField nub commaSepTextField 93 | 94 | resPublishedForm :: Maybe (Maybe YearPublished) -> AForm Handler (Maybe YearPublished) 95 | resPublishedForm = aopt intField "Year (optional)" 96 | 97 | resTypeForm :: Maybe ResourceType -> AForm Handler ResourceType 98 | resTypeForm = areq field "Type" 99 | where 100 | field :: Field Handler ResourceType 101 | field = selectFieldList $ map (descResourceType &&& id) [minBound..maxBound] 102 | 103 | resTagsForm :: Maybe [TagNameText] -> AForm Handler [TagNameText] 104 | resTagsForm = areq field "Tags (comma separated)" 105 | where 106 | field :: Field Handler [Text] 107 | field = mapField nub commaSepTextField 108 | 109 | resCollectionsForm :: Maybe [CollectionNameText] -> AForm Handler [CollectionNameText] 110 | resCollectionsForm = fmap (fromMaybe []) . aopt field "Collection(s) (optional, comma separated)" . fmap Just 111 | where 112 | field :: Field Handler [Text] 113 | field = mapField nub commaSepTextField 114 | 115 | -- | Display meta-information about the resource. 116 | resourceInfoWidget :: Entity Resource -> Widget 117 | resourceInfoWidget (Entity res_id res) = do 118 | (poster, authors, tags, colls) <- handlerToWidget . runDB $ (,,,) 119 | <$> get404 (resourceUserId res) 120 | <*> (map authorName <$> fetchResourceAuthorsDB res_id) 121 | <*> (map tagName <$> fetchResourceTagsDB res_id) 122 | <*> (map collectionName <$> fetchResourceCollectionsDB res_id) 123 | posted <- prettyAgo (resourcePosted res) 124 | 125 | $(widgetFile "resource-info") 126 | -------------------------------------------------------------------------------- /src/View/User.hs: -------------------------------------------------------------------------------- 1 | module View.User where 2 | 3 | import Import 4 | 5 | import Data.Char (isAlphaNum) 6 | import qualified Data.Text as T 7 | 8 | displayNameForm :: Maybe Text -> Form Text 9 | displayNameForm = renderDivs . areq (validateNameField textField) "" 10 | where 11 | validateNameField :: Field Handler Text -> Field Handler Text 12 | validateNameField = checkBool validName ("Only alphanumeric characters allowed."::Text) 13 | 14 | validName :: Text -> Bool 15 | validName = allCharsSatisfy isAlphaNum 16 | 17 | allCharsSatisfy :: (Char -> Bool) -> Text -> Bool 18 | allCharsSatisfy f = T.foldr (\c b -> f c && b) True 19 | -------------------------------------------------------------------------------- /src/Yesod/Form/Types/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Yesod.Form.Types.Extra 4 | ( commaSepTextField 5 | , fmapField 6 | , mapField 7 | , parsedTextField 8 | ) where 9 | 10 | import Import 11 | 12 | import Data.Attoparsec.Text (Parser, char, many1, notChar, parseOnly, sepBy1, skipSpace) 13 | 14 | import qualified Data.Text as T 15 | 16 | commaSepTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m [Text] 17 | commaSepTextField = parsedTextField parseTexts showTexts 18 | where 19 | parseTexts :: Parser [Text] 20 | parseTexts = parseText `sepBy1` char ',' 21 | 22 | parseText :: Parser Text 23 | parseText = T.pack <$> token (many1 $ notChar ',') 24 | 25 | token :: Parser a -> Parser a 26 | token p = skipSpace *> p <* skipSpace 27 | 28 | showTexts :: [Text] -> Text 29 | showTexts = T.intercalate ", " 30 | 31 | fmapField :: forall a b m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => (a -> b) -> (b -> a) -> Field m a -> Field m b 32 | fmapField f = checkMMap (return . Right . f :: a -> m (Either FormMessage b)) 33 | 34 | mapField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => (a -> a) -> Field m a -> Field m a 35 | mapField f = fmapField f id 36 | 37 | parsedTextField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Parser a -> (a -> Text) -> Field m a 38 | parsedTextField parser shower = Field 39 | { fieldParse = parseHelper $ \s -> 40 | case parseOnly parser s of 41 | Left err -> Left $ MsgInvalidEntry $ "Parse error: " <> (T.pack err) 42 | Right xs -> Right xs 43 | , fieldView = \theId name attrs val isReq -> 44 | [whamlet| 45 | $newline never 46 | 47 | |] 48 | , fieldEnctype = UrlEncoded 49 | } 50 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | packages: 2 | - '.' 3 | extra-deps: 4 | - yesod-markdown-0.11.1 5 | resolver: lts-6.1 6 | -------------------------------------------------------------------------------- /static/css/normalize.css: -------------------------------------------------------------------------------- 1 | /*! normalize.css v2.1.2 | MIT License | git.io/normalize */ 2 | 3 | /* ========================================================================== 4 | HTML5 display definitions 5 | ========================================================================== */ 6 | 7 | /** 8 | * Correct `block` display not defined in IE 8/9. 9 | */ 10 | 11 | article, 12 | aside, 13 | details, 14 | figcaption, 15 | figure, 16 | footer, 17 | header, 18 | hgroup, 19 | main, 20 | nav, 21 | section, 22 | summary { 23 | display: block; 24 | } 25 | 26 | /** 27 | * Correct `inline-block` display not defined in IE 8/9. 28 | */ 29 | 30 | audio, 31 | canvas, 32 | video { 33 | display: inline-block; 34 | } 35 | 36 | /** 37 | * Prevent modern browsers from displaying `audio` without controls. 38 | * Remove excess height in iOS 5 devices. 39 | */ 40 | 41 | audio:not([controls]) { 42 | display: none; 43 | height: 0; 44 | } 45 | 46 | /** 47 | * Address styling not present in IE 8/9. 48 | */ 49 | 50 | [hidden] { 51 | display: none; 52 | } 53 | 54 | /* ========================================================================== 55 | Base 56 | ========================================================================== */ 57 | 58 | /** 59 | * 1. Set default font family to sans-serif. 60 | * 2. Prevent iOS text size adjust after orientation change, without disabling 61 | * user zoom. 62 | */ 63 | 64 | html { 65 | font-family: sans-serif; /* 1 */ 66 | -ms-text-size-adjust: 100%; /* 2 */ 67 | -webkit-text-size-adjust: 100%; /* 2 */ 68 | } 69 | 70 | /** 71 | * Remove default margin. 72 | */ 73 | 74 | body { 75 | margin: 0; 76 | } 77 | 78 | /* ========================================================================== 79 | Links 80 | ========================================================================== */ 81 | 82 | /** 83 | * Address `outline` inconsistency between Chrome and other browsers. 84 | */ 85 | 86 | a:focus { 87 | outline: thin dotted; 88 | } 89 | 90 | /** 91 | * Improve readability when focused and also mouse hovered in all browsers. 92 | */ 93 | 94 | a:active, 95 | a:hover { 96 | outline: 0; 97 | } 98 | 99 | /* ========================================================================== 100 | Typography 101 | ========================================================================== */ 102 | 103 | /** 104 | * Address variable `h1` font-size and margin within `section` and `article` 105 | * contexts in Firefox 4+, Safari 5, and Chrome. 106 | */ 107 | 108 | h1 { 109 | font-size: 2em; 110 | margin: 0.67em 0; 111 | } 112 | 113 | /** 114 | * Address styling not present in IE 8/9, Safari 5, and Chrome. 115 | */ 116 | 117 | abbr[title] { 118 | border-bottom: 1px dotted; 119 | } 120 | 121 | /** 122 | * Address style set to `bolder` in Firefox 4+, Safari 5, and Chrome. 123 | */ 124 | 125 | b, 126 | strong { 127 | font-weight: bold; 128 | } 129 | 130 | /** 131 | * Address styling not present in Safari 5 and Chrome. 132 | */ 133 | 134 | dfn { 135 | font-style: italic; 136 | } 137 | 138 | /** 139 | * Address differences between Firefox and other browsers. 140 | */ 141 | 142 | hr { 143 | -moz-box-sizing: content-box; 144 | box-sizing: content-box; 145 | height: 0; 146 | } 147 | 148 | /** 149 | * Address styling not present in IE 8/9. 150 | */ 151 | 152 | mark { 153 | background: #ff0; 154 | color: #000; 155 | } 156 | 157 | /** 158 | * Correct font family set oddly in Safari 5 and Chrome. 159 | */ 160 | 161 | code, 162 | kbd, 163 | pre, 164 | samp { 165 | font-family: monospace, serif; 166 | font-size: 1em; 167 | } 168 | 169 | /** 170 | * Improve readability of pre-formatted text in all browsers. 171 | */ 172 | 173 | pre { 174 | white-space: pre-wrap; 175 | } 176 | 177 | /** 178 | * Set consistent quote types. 179 | */ 180 | 181 | q { 182 | quotes: "\201C" "\201D" "\2018" "\2019"; 183 | } 184 | 185 | /** 186 | * Address inconsistent and variable font size in all browsers. 187 | */ 188 | 189 | small { 190 | font-size: 80%; 191 | } 192 | 193 | /** 194 | * Prevent `sub` and `sup` affecting `line-height` in all browsers. 195 | */ 196 | 197 | sub, 198 | sup { 199 | font-size: 75%; 200 | line-height: 0; 201 | position: relative; 202 | vertical-align: baseline; 203 | } 204 | 205 | sup { 206 | top: -0.5em; 207 | } 208 | 209 | sub { 210 | bottom: -0.25em; 211 | } 212 | 213 | /* ========================================================================== 214 | Embedded content 215 | ========================================================================== */ 216 | 217 | /** 218 | * Remove border when inside `a` element in IE 8/9. 219 | */ 220 | 221 | img { 222 | border: 0; 223 | } 224 | 225 | /** 226 | * Correct overflow displayed oddly in IE 9. 227 | */ 228 | 229 | svg:not(:root) { 230 | overflow: hidden; 231 | } 232 | 233 | /* ========================================================================== 234 | Figures 235 | ========================================================================== */ 236 | 237 | /** 238 | * Address margin not present in IE 8/9 and Safari 5. 239 | */ 240 | 241 | figure { 242 | margin: 0; 243 | } 244 | 245 | /* ========================================================================== 246 | Forms 247 | ========================================================================== */ 248 | 249 | /** 250 | * Define consistent border, margin, and padding. 251 | */ 252 | 253 | fieldset { 254 | border: 1px solid #c0c0c0; 255 | margin: 0 2px; 256 | padding: 0.35em 0.625em 0.75em; 257 | } 258 | 259 | /** 260 | * 1. Correct `color` not being inherited in IE 8/9. 261 | * 2. Remove padding so people aren't caught out if they zero out fieldsets. 262 | */ 263 | 264 | legend { 265 | border: 0; /* 1 */ 266 | padding: 0; /* 2 */ 267 | } 268 | 269 | /** 270 | * 1. Correct font family not being inherited in all browsers. 271 | * 2. Correct font size not being inherited in all browsers. 272 | * 3. Address margins set differently in Firefox 4+, Safari 5, and Chrome. 273 | */ 274 | 275 | button, 276 | input, 277 | select, 278 | textarea { 279 | font-family: inherit; /* 1 */ 280 | font-size: 100%; /* 2 */ 281 | margin: 0; /* 3 */ 282 | } 283 | 284 | /** 285 | * Address Firefox 4+ setting `line-height` on `input` using `!important` in 286 | * the UA stylesheet. 287 | */ 288 | 289 | button, 290 | input { 291 | line-height: normal; 292 | } 293 | 294 | /** 295 | * Address inconsistent `text-transform` inheritance for `button` and `select`. 296 | * All other form control elements do not inherit `text-transform` values. 297 | * Correct `button` style inheritance in Chrome, Safari 5+, and IE 8+. 298 | * Correct `select` style inheritance in Firefox 4+ and Opera. 299 | */ 300 | 301 | button, 302 | select { 303 | text-transform: none; 304 | } 305 | 306 | /** 307 | * 1. Avoid the WebKit bug in Android 4.0.* where (2) destroys native `audio` 308 | * and `video` controls. 309 | * 2. Correct inability to style clickable `input` types in iOS. 310 | * 3. Improve usability and consistency of cursor style between image-type 311 | * `input` and others. 312 | */ 313 | 314 | button, 315 | html input[type="button"], /* 1 */ 316 | input[type="reset"], 317 | input[type="submit"] { 318 | -webkit-appearance: button; /* 2 */ 319 | cursor: pointer; /* 3 */ 320 | } 321 | 322 | /** 323 | * Re-set default cursor for disabled elements. 324 | */ 325 | 326 | button[disabled], 327 | html input[disabled] { 328 | cursor: default; 329 | } 330 | 331 | /** 332 | * 1. Address box sizing set to `content-box` in IE 8/9. 333 | * 2. Remove excess padding in IE 8/9. 334 | */ 335 | 336 | input[type="checkbox"], 337 | input[type="radio"] { 338 | box-sizing: border-box; /* 1 */ 339 | padding: 0; /* 2 */ 340 | } 341 | 342 | /** 343 | * 1. Address `appearance` set to `searchfield` in Safari 5 and Chrome. 344 | * 2. Address `box-sizing` set to `border-box` in Safari 5 and Chrome 345 | * (include `-moz` to future-proof). 346 | */ 347 | 348 | input[type="search"] { 349 | -webkit-appearance: textfield; /* 1 */ 350 | -moz-box-sizing: content-box; 351 | -webkit-box-sizing: content-box; /* 2 */ 352 | box-sizing: content-box; 353 | } 354 | 355 | /** 356 | * Remove inner padding and search cancel button in Safari 5 and Chrome 357 | * on OS X. 358 | */ 359 | 360 | input[type="search"]::-webkit-search-cancel-button, 361 | input[type="search"]::-webkit-search-decoration { 362 | -webkit-appearance: none; 363 | } 364 | 365 | /** 366 | * Remove inner padding and border in Firefox 4+. 367 | */ 368 | 369 | button::-moz-focus-inner, 370 | input::-moz-focus-inner { 371 | border: 0; 372 | padding: 0; 373 | } 374 | 375 | /** 376 | * 1. Remove default vertical scrollbar in IE 8/9. 377 | * 2. Improve readability and alignment in all browsers. 378 | */ 379 | 380 | textarea { 381 | overflow: auto; /* 1 */ 382 | vertical-align: top; /* 2 */ 383 | } 384 | 385 | /* ========================================================================== 386 | Tables 387 | ========================================================================== */ 388 | 389 | /** 390 | * Remove most spacing between table cells. 391 | */ 392 | 393 | table { 394 | border-collapse: collapse; 395 | border-spacing: 0; 396 | } 397 | -------------------------------------------------------------------------------- /static/img/circle-outline.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/circle-outline.png -------------------------------------------------------------------------------- /static/img/circle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/circle.png -------------------------------------------------------------------------------- /static/img/edit.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/edit.png -------------------------------------------------------------------------------- /static/img/glyphicons-halflings-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/glyphicons-halflings-white.png -------------------------------------------------------------------------------- /static/img/glyphicons-halflings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/glyphicons-halflings.png -------------------------------------------------------------------------------- /static/img/lambda.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/lambda.png -------------------------------------------------------------------------------- /static/img/right-arrow.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/right-arrow.png -------------------------------------------------------------------------------- /static/img/star-outline.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/star-outline.png -------------------------------------------------------------------------------- /static/img/star.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mitchellwrosen/dohaskell/69aea7a42112557ac3e835b9dbdb9bf60a81f780/static/img/star.png -------------------------------------------------------------------------------- /templates/about.cassius: -------------------------------------------------------------------------------- 1 | p 2 | font-size: 1.2em 3 | line-height: 1.3em 4 | margin: 20px auto 5 | text-align: justify 6 | width: 30em 7 | 8 | hr 9 | border: 0 10 | height: 1px 11 | background: #333 12 | background-image: -webkit-linear-gradient(left, #ccc, #333, #ccc) 13 | background-image: -ms-linear-gradient(left, #ccc, #333, #ccc) 14 | background-image: -o-linear-gradient(left, #ccc, #333, #ccc) 15 | background-image: -moz-linear-gradient(left, #ccc, #333, #ccc) 16 | margin: 50px auto 17 | width: 30em 18 | 19 | .small 20 | font-size: 0.9em 21 | -------------------------------------------------------------------------------- /templates/about.hamlet: -------------------------------------------------------------------------------- 1 |

2 | Officially, 3 | dohaskell 4 | is a tagged Haskell learning resources index. Unofficially, it's a glorified bookmarks folder. 5 | Submit links to your favorite blog posts, research papers, and video lectures - then tag 6 | them for others to discover! 7 | 8 |

9 | 10 | Pro tip: poke around the 11 | feeds 12 | \ page and discover a way to quickly determine which links from your favorite Haskelly RSS/Atom 13 | feed have already made it on the site. 14 | 15 |

16 | dohaskell was built for and is maintained by the Haskell community. Resource metadata is managed 17 | by the original submitter, so any modifications you'd like to make to an existing resource 18 | (e.g. add or delete a tag) must be approved by that person. This is simply to help prevent people from 19 | intentionally adding bogus tags or deleting data. Of course, nothing is stopping you from submitting 20 | and maintaining your own bogus links ;). 21 | 22 | $maybe uid <- muid 23 |

24 | You can see your list of requested edits 25 | here# 26 | , accessed through your 27 | profile# 28 | . 29 | 30 |

31 | If you'd like to submit a resource but don't want to be responsible for responding to any edit 32 | requests, that's fine — I can approve or deny edits on your behalf. Eventually I may implement a 33 | "relinquish ownership" feature, although I don't anticipate any huge problems with the current system. 34 | Resource edit requests will generally be tweaking tag names to better match existing tags, or fixing typos 35 | in resource titles. 36 | 37 |

38 | dohaskell is open-source, written entirely in Haskell using the 39 | Yesod 40 | web framework. If you dig it, please 41 | contribute! 42 | 43 |

44 | 45 |

46 | dohaskell is most useful with minimal noise. So, try to conform to existing tags, including capitalization 47 | and plurality. Tags are case-sensitive by design: consider functor vs. Functor, or 48 | GHC (a blog post about internals) vs. ghc (an index of useful command-line flags). 49 | 50 |

51 | Meta-resources, such as 52 | this# 53 | , are better submitted one 54 | link at a time. Obviously, depending on the size, this may be an inordinate amount of work. Feel free to 55 | submit the meta-resource itself, using a tag like miscellaneous, but avoid tagging it with each 56 | tag of its constituents - it will quickly become noise. 57 | 58 |

59 | Online courses are similarly difficult to tag. Perhaps they should all be tagged with online course 60 | and nothing more, as again, tagging with each constituent component is noisy. 61 | 62 |

63 | This is not to say that single, pointed resources should be conservative in their tags. Actually, the more 64 | tags, the better, as long as each tag is appropriate. Consider the monad tag: although a huge number 65 | of resources may use monads, only some percentage of them are about monads in some way. Use 66 | your best judgement. 67 | 68 |

69 | Thanks for making it this far, and happy Haskelling! 70 | 71 |

72 | -------------------------------------------------------------------------------- /templates/browse.cassius: -------------------------------------------------------------------------------- 1 | .count 2 | clear: left 3 | float: left 4 | margin-right: 5px 5 | text-align: right 6 | width: 40px 7 | 8 | .year-range 9 | color: gray 10 | font-size: 0.8em 11 | font-style: italic 12 | 13 | .expand 14 | float: none 15 | font-size: 1.2em 16 | overflow: hidden 17 | padding-left: 5px 18 | 19 | .arrow 20 | float: right 21 | height: 100% 22 | text-align: center 23 | width: 30px 24 | 25 | .arrow:hover 26 | background-color: #eee 27 | 28 | .expand:hover 29 | background-color: #eee 30 | 31 | .expand:hover * 32 | color: black 33 | 34 | .col 35 | height: 25px 36 | line-height: 25px 37 | 38 | .res-container 39 | margin-left: 50px 40 | -------------------------------------------------------------------------------- /templates/browse.hamlet: -------------------------------------------------------------------------------- 1 | $forall entity <- entities 2 | $with total_counts <- M.findWithDefault 0 (get_maps_key entity) total_counts 3 |
4 | $maybe grokked_counts <- mgrokked_counts 5 |
6 | #{show $ M.findWithDefault 0 (get_maps_key entity) grokked_counts}/#{show total_counts} 7 | $nothing 8 |
9 | #{show total_counts} 10 | 11 | 12 | 13 | 14 |
15 | #{show_entity entity} 16 | $maybe (m, n) <- M.lookup (get_maps_key entity) year_ranges 17 | $if m == n 18 | | #{show m} 19 | $else 20 | | #{show m} - #{show n} 21 | 22 |
23 | -------------------------------------------------------------------------------- /templates/browse.julius: -------------------------------------------------------------------------------- 1 | function expand(elem) { 2 | resourceContainer = $(elem).siblings('.res-container') 3 | 4 | resourceContainer.show(); 5 | if (!$(elem).hasClass('fetched')) { 6 | uri = #{path_piece} + encodeURIComponent($(elem).attr('id')) + '?embed&sort-res=' + #{sort_res_by_text}; 7 | onFetch = function() { $(elem).addClass('fetched'); } 8 | resourceContainer.load(uri, onFetch); 9 | } 10 | } 11 | 12 | function collapse(elem) { 13 | $(elem).siblings('.res-container').hide(); 14 | } 15 | 16 | function clickExpand() { 17 | $(this).toggleClass('exp'); 18 | if ($(this).hasClass('exp')) 19 | expand(this); 20 | else 21 | collapse(this); 22 | } 23 | 24 | $(document).ready(function() { 25 | $('.expand').click(clickExpand); 26 | }); 27 | -------------------------------------------------------------------------------- /templates/default-layout-wrapper.hamlet: -------------------------------------------------------------------------------- 1 | $doctype 5 2 | 3 | 4 | #{pageTitle pc} 5 | ^{pageHead pc} 6 | <body> 7 | ^{pageBody pc} 8 | -------------------------------------------------------------------------------- /templates/default-layout.cassius: -------------------------------------------------------------------------------- 1 | #message 2 | font-weight: bold 3 | height: 30px 4 | line-height: 30px 5 | margin: 0px 0px 5px 0px 6 | padding: 0px 0px 0px 5px 7 | background-color: #E9CFEC 8 | 9 | #content 10 | margin: 52px 10px 30px 10px 11 | 12 | body 13 | font-family: Helvetica 14 | 15 | a, .link-like 16 | color: #069 17 | -------------------------------------------------------------------------------- /templates/default-layout.hamlet: -------------------------------------------------------------------------------- 1 | ^{navbarWidget} 2 | 3 | <div #content> 4 | $maybe msg <- mmsg 5 | <div #message>#{msg} 6 | 7 | ^{innerWidget} 8 | -------------------------------------------------------------------------------- /templates/feeds.cassius: -------------------------------------------------------------------------------- 1 | .header 2 | border-bottom: 1px solid black 3 | font-size: 1.2em 4 | line-height: 1.3em 5 | margin: 20px auto 6 | text-align: justify 7 | width: 30em 8 | 9 | .feed 10 | font-size: 1.2em 11 | margin: 0 auto 12 | width: 30em 13 | 14 | .feed-title 15 | color: gray 16 | font-size: 0.9em 17 | 18 | .feed-url 19 | color: #069 20 | -------------------------------------------------------------------------------- /templates/feeds.hamlet: -------------------------------------------------------------------------------- 1 | <div .header> 2 | <p> 3 | The resources in the feeds below are not automatically added to dohaskell.com; 4 | rather, this page simply serves as a (somewhat) convenient way to see which links 5 | have already been submitted. 6 | 7 | <form method=get action=@{FeedR} enctype=#{UrlEncoded}> 8 | <div> 9 | <label>Add Feed 10 | <input type=url name=url placeholder="http://"> 11 | <button type=submit name=type value="#{show Atom}">Atom 1.0 12 | <button type=submit name=type value="#{show RSS2}">RSS 2.0 13 | 14 | $forall (title, url, feed_type) <- feeds 15 | <div .feed> 16 | <a .feed-url href=@?{(FeedR, [("url", url), ("type", T.pack (show feed_type))])}>#{url} 17 | <div .feed-title>— #{title} 18 | -------------------------------------------------------------------------------- /templates/navbar.cassius: -------------------------------------------------------------------------------- 1 | #logo 2 | height: auto 3 | width: 50px 4 | margin: 5px 5 | position: fixed 6 | top: 0 7 | z-index: 2 8 | 9 | #nav 10 | background-color: #f2f2f2 11 | box-shadow: 0px 0px 8px 0px #000 12 | list-style-type: none 13 | font-size: 18px 14 | margin: 0 15 | padding: 0 16 | position: fixed 17 | text-align: center 18 | top: 0; 19 | width: 100% 20 | z-index: 1 21 | 22 | #nav li 23 | display: inline 24 | 25 | #nav a 26 | color: #569 27 | display: inline-block 28 | font-weight: bold 29 | margin: 4px 0px 30 | padding: 8px 20px 31 | text-decoration: none 32 | 33 | #nav li a:hover 34 | background-color: #d2d2d2 35 | color: #000 36 | -------------------------------------------------------------------------------- /templates/navbar.hamlet: -------------------------------------------------------------------------------- 1 | <a href=@{HomeR}> 2 | <img #logo src=@{StaticR img_lambda_png}> 3 | 4 | <ul #nav> 5 | <li> 6 | <a href=@{BrowseTagsR}>browse 7 | <li> 8 | <a href=@{SubmitR}>submit 9 | 10 | $maybe uid <- muid 11 | <li> 12 | <a href=@{UserR uid}>profile 13 | <li> 14 | <a href=@{AuthR LogoutR}>log out 15 | $nothing 16 | <li> 17 | <a href=@{AuthR LoginR}>log in 18 | 19 | <li> 20 | <a href=@{AboutR}>about 21 | -------------------------------------------------------------------------------- /templates/requested-edits-hub.cassius: -------------------------------------------------------------------------------- 1 | .no-edits 2 | font-size: 30px 3 | font-weight: bold 4 | 5 | .resource 6 | border-left: 2px solid 7 | border-bottom-left-radius: 15px 8 | 9 | .resource-body 10 | margin-left: 10px 11 | 12 | .edit 13 | border-left: 2px solid 14 | border-bottom-left-radius: 15px 15 | 16 | .edit-body 17 | margin-left: 10px 18 | -------------------------------------------------------------------------------- /templates/requested-edits-hub.hamlet: -------------------------------------------------------------------------------- 1 | $if areNoRequestedEdits 2 | <div .no-edits>No requested edits! 3 | $else 4 | $forall res <- resources 5 | <div .resource> 6 | <div .resource-body> 7 | ^{resourceInfoWidget res} 8 | 9 | $forall Entity edit_id (EditTitle _ title) <- maybe [] id (M.lookup res editTitles) 10 | <div .edit> 11 | <div .edit-body> 12 | Title: #{title} 13 | <form method=post> 14 | <input type=submit formaction=@{EditTitleAcceptR edit_id} value=Accept> 15 | <input type=submit formaction=@{EditTitleDeclineR edit_id} value=Decline> 16 | 17 | $forall Entity edit_id (EditAuthors _ authors) <- maybe [] id (M.lookup res editAuthors) 18 | <div .edit> 19 | <div .edit-body> 20 | Authors: #{T.intercalate ", " authors} 21 | <form method=post> 22 | <input type=submit formaction=@{EditAuthorsAcceptR edit_id} value=Accept> 23 | <input type=submit formaction=@{EditAuthorsDeclineR edit_id} value=Decline> 24 | 25 | $# TODO(mitchell): Nicer html/css for this... year :: Maybe Int, so the user is shown 26 | $# 'Just 2005' or 'Nothing', depending on if the edit was modifying the year or deleting 27 | $# it outright. 28 | $forall Entity edit_id (EditPublished _ year) <- maybe [] id (M.lookup res editPublished) 29 | <div .edit> 30 | <div .edit-body> 31 | Year: #{show year} 32 | <form method=post> 33 | <input type=submit formaction=@{EditPublishedAcceptR edit_id} value=Accept> 34 | <input type=submit formaction=@{EditPublishedDeclineR edit_id} value=Decline> 35 | 36 | $forall Entity edit_id edit <- maybe [] id (M.lookup res editTypes) 37 | <div .edit> 38 | <div .edit-body> 39 | Type: #{editTypeType edit} 40 | <form method=post> 41 | <input type=submit formaction=@{EditTypeAcceptR edit_id} value=Accept> 42 | <input type=submit formaction=@{EditTypeDeclineR edit_id} value=Decline> 43 | 44 | $forall Entity edit_id edit <- maybe [] id (M.lookup res editAddTags) 45 | <div .edit> 46 | <div .edit-body> 47 | Add tag: #{editAddTagText edit} 48 | <form method=post> 49 | <input type=submit formaction=@{EditAddTagAcceptR edit_id} value=Accept> 50 | <input type=submit formaction=@{EditAddTagDeclineR edit_id} value=Decline> 51 | 52 | $forall Entity edit_id edit <- maybe [] id (M.lookup res editRemoveTags) 53 | <div .edit> 54 | <div .edit-body> 55 | Remove tag: #{editRemoveTagText edit} 56 | <form method=post> 57 | <input type=submit formaction=@{EditRemoveTagAcceptR edit_id} value=Accept> 58 | <input type=submit formaction=@{EditRemoveTagDeclineR edit_id} value=Decline> 59 | 60 | $forall Entity edit_id edit <- maybe [] id (M.lookup res editAddCollections) 61 | <div .edit> 62 | <div .edit-body> 63 | Add collection: #{editAddCollectionName edit} 64 | <form method=post> 65 | <input type=submit formaction=@{EditAddCollectionAcceptR edit_id} value=Accept> 66 | <input type=submit formaction=@{EditAddCollectionDeclineR edit_id} value=Decline> 67 | 68 | $forall Entity edit_id edit <- maybe [] id (M.lookup res editRemoveCollections) 69 | <div .edit> 70 | <div .edit-body> 71 | Remove collection: #{editRemoveCollectionName edit} 72 | <form method=post> 73 | <input type=submit formaction=@{EditRemoveCollectionAcceptR edit_id} value=Accept> 74 | <input type=submit formaction=@{EditRemoveCollectionDeclineR edit_id} value=Decline> 75 | -------------------------------------------------------------------------------- /templates/resource-comments.hamlet: -------------------------------------------------------------------------------- 1 | #{resourceTitle resource} - comments 2 | ^{resourceCommentForestWidget comment_forest} 3 | -------------------------------------------------------------------------------- /templates/resource-info.cassius: -------------------------------------------------------------------------------- 1 | .res-title 2 | color: #069 3 | font-size: 30px 4 | font-weight: bold 5 | margin-top: 5px 6 | 7 | .res-meta-info 8 | font-size: 20px 9 | color: gray 10 | 11 | .res-tags 12 | font-style: italic 13 | -------------------------------------------------------------------------------- /templates/resource-info.hamlet: -------------------------------------------------------------------------------- 1 | <a .res-title href=#{resourceUrl res}>#{resourceTitle res} 2 | 3 | <div .res-meta-info> 4 | <div .res-published-type-authors> 5 | $maybe published <- resourcePublished res 6 | <span .res-published>#{show published} 7 | 8 | <span .res-type>#{shortDescResourceType $ resourceType res} 9 | 10 | $if not (null authors) 11 | <span .res-authors-by> by 12 | <span .res-authors> #{T.intercalate ", " $ authors} 13 | 14 | <div .res-tags> 15 | <span .res-tag>#{T.intercalate ", " tags} 16 | 17 | <div .res-colls> 18 | <span .res-coll>#{T.intercalate "," colls} 19 | 20 | <div .res-user>Posted #{posted} by # 21 | <a href=@{UserR $ resourceUserId res}>#{userDisplayName poster} 22 | -------------------------------------------------------------------------------- /templates/resource-list-logged-in.julius: -------------------------------------------------------------------------------- 1 | function onPostFailure(xhr, textStatus, errorThrown) { 2 | console.log("Failure: " + xhr.responseText); 3 | } 4 | 5 | $(document).ready(function() { 6 | $('.res-grok').click(function() { 7 | $(this).toggleClass('grok'); 8 | 9 | if ($(this).hasClass('grok')) 10 | $.post('/r/list/grokked/add/' + $(this).attr('id')) 11 | .fail(onPostFailure) 12 | else 13 | $.post('/r/list/grokked/del/' + $(this).attr('id')) 14 | .fail(onPostFailure) 15 | }); 16 | }); 17 | -------------------------------------------------------------------------------- /templates/resource-list-not-logged-in.julius: -------------------------------------------------------------------------------- 1 | $(document).ready(function() { 2 | $('.res-fav').click(function() { alert('Please log in to favorite a resource!') }); 3 | $('.res-grok').click(function() { alert('Please log in to grok a resource!') }); 4 | }); 5 | -------------------------------------------------------------------------------- /templates/resource-list.cassius: -------------------------------------------------------------------------------- 1 | .res-grok 2 | background: url(@{StaticR img_circle_outline_png}) 3 | background-position: center 4 | background-repeat: no-repeat 5 | background-size: 14px 14px 6 | float: left 7 | height: 100% 8 | width: 16px 9 | 10 | .res-grok:hover 11 | background: url(@{StaticR img_circle_outline_png}) 12 | background-position: center 13 | background-repeat: no-repeat 14 | background-size: 16px 16px 15 | 16 | .res-grok.grok 17 | background: url(@{StaticR img_circle_png}) 18 | background-position: center 19 | background-repeat: no-repeat 20 | background-size: 14px 14px 21 | 22 | .res-grok.grok:hover 23 | background: url(@{StaticR img_circle_png}) 24 | background-position: center 25 | background-repeat: no-repeat 26 | background-size: 16px 16px 27 | 28 | .res-ext 29 | font-size: 0.9em 30 | font-variant: small-caps 31 | margin-left: 5px 32 | 33 | .res-ext-pdf 34 | color: #A69 35 | 36 | .res-ext-ps 37 | color: #B69 38 | 39 | .res-title 40 | display: inline-block 41 | font-size: 1.2em 42 | font-weight: bold 43 | margin-top: 2px 44 | 45 | .res-published-type-authors 46 | margin-top: -3px 47 | 48 | .res-authors 49 | font-weight: bold 50 | 51 | .res-published, .res-type, .res-authors-by, .res-authors 52 | color: gray 53 | font-size: 1em 54 | 55 | .res-url 56 | display: block 57 | height: 100% 58 | overflow: hidden 59 | padding: 0px 5px 60 | 61 | .res-url:hover .res-title 62 | color: black 63 | 64 | .res-url:hover .res-ext 65 | color: gray 66 | 67 | .res-info 68 | background: url(@{StaticR img_edit_png}) 69 | background-position: center 70 | background-repeat: no-repeat 71 | background-size: 20px 20px 72 | float: right 73 | width: 30px 74 | height: 100% 75 | text-decoration: none 76 | 77 | .res-li 78 | height: 40px 79 | 80 | .res-li a 81 | text-decoration: none 82 | 83 | .res-li > * 84 | vertical-align: middle 85 | 86 | .res-link:hover 87 | background-color: #eee 88 | -------------------------------------------------------------------------------- /templates/resource-list.hamlet: -------------------------------------------------------------------------------- 1 | $forall Entity res_id res <- resources 2 | <div .res-li> 3 | 4 | <div .res-grok :S.member res_id grokked:.grok ##{toPathPiece res_id} title="Grok"> 5 | 6 | <a .res-info .res-link href=@{ResourceR res_id}> 7 | 8 | <a .res-url .res-link href=#{resourceUrl res}> 9 | <div .res-title>#{resourceTitle res} 10 | $maybe ext <- resourceExtension res 11 | <span .res-ext .res-ext-#{ext}> (#{ext}) 12 | 13 | <div .res-published-type-authors> 14 | $maybe published <- resourcePublished res 15 | <span .res-published>#{show published} 16 | <span .res-type>#{shortDescResourceType $ resourceType res} 17 | $maybe authors <- map authorName <$> M.lookup res_id authorsMap 18 | <span .res-authors-by> by 19 | <span .res-authors> #{T.intercalate ", " $ authors} 20 | -------------------------------------------------------------------------------- /templates/resource.cassius: -------------------------------------------------------------------------------- 1 | #resource-body 2 | margin: 10px 3 | 4 | .form-group 5 | margin-bottom: 10px 6 | 7 | form 8 | width: 50em 9 | 10 | input 11 | width: 50em 12 | 13 | label 14 | font-size: 18px 15 | font-family: Helvetica 16 | -------------------------------------------------------------------------------- /templates/resource.hamlet: -------------------------------------------------------------------------------- 1 | ^{info_widget} 2 | ^{edit_widget} 3 | -------------------------------------------------------------------------------- /templates/submit.cassius: -------------------------------------------------------------------------------- 1 | .form-group 2 | margin-bottom: 10px 3 | 4 | form 5 | width: 50em 6 | margin: 10px 7 | 8 | input 9 | width: 50em 10 | 11 | label 12 | font-size: 18px 13 | font-family: Helvetica 14 | -------------------------------------------------------------------------------- /templates/submit.hamlet: -------------------------------------------------------------------------------- 1 | <form method=post action=@{SubmitR} enctype=#{enctype}> 2 | ^{widget} 3 | -------------------------------------------------------------------------------- /templates/user.cassius: -------------------------------------------------------------------------------- 1 | .header 2 | font-size: 1.5em 3 | font-weight: bold 4 | border-bottom: 1px solid gray 5 | margin-bottom: 5px 6 | 7 | .info 8 | margin-bottom: 1.5em 9 | 10 | .profile 11 | font-size: 1.2em 12 | line-height: 1.3em 13 | 14 | .display-name 15 | font-weight: bold 16 | 17 | .res-nums 18 | margin-left: 10px 19 | 20 | .grokked-per-week 21 | color: gray 22 | -------------------------------------------------------------------------------- /templates/user.hamlet: -------------------------------------------------------------------------------- 1 | <div .profile> 2 | <div .info> 3 | <div .display-name>#{userDisplayName user} 4 | <div .res-nums> 5 | <div> 6 | <a href=@{UserSubmittedR user_id}>#{num_submitted} submitted 7 | <div> 8 | <a href=@{UserListR user_id "grokked"}>#{num_grokked} grokked 9 | 10 | $if is_own_profile 11 | <div .settings> 12 | <div .header>Settings 13 | <div>Login ID (hidden): <strong>#{userName user}</strong> 14 | 15 | <form method=post action=@{UserR user_id} enctype=#{enctype}> 16 | ^{widget} 17 | <input type="submit" value="Update Display Name"> 18 | 19 | <div .req-edits> 20 | <a href=@{ReqEditsHubR user_id}>#{num_req_edits} requested #{plural num_req_edits "edit"} 21 | -------------------------------------------------------------------------------- /tests/HomeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module HomeTest 3 | ( homeSpecs 4 | ) where 5 | 6 | import TestImport 7 | import qualified Data.List as L 8 | 9 | homeSpecs :: Spec 10 | homeSpecs = 11 | ydescribe "These are some example tests" $ do 12 | 13 | yit "loads the index and checks it looks right" $ do 14 | get HomeR 15 | statusIs 200 16 | htmlAllContain "h1" "Hello" 17 | 18 | request $ do 19 | setMethod "POST" 20 | setUrl HomeR 21 | addNonce 22 | fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference 23 | byLabel "What's on the file?" "Some Content" 24 | 25 | statusIs 200 26 | printBody 27 | htmlCount ".message" 1 28 | htmlAllContain ".message" "Some Content" 29 | htmlAllContain ".message" "text/plain" 30 | 31 | -- This is a simple example of using a database access in a test. The 32 | -- test will succeed for a fresh scaffolded site with an empty database, 33 | -- but will fail on an existing database with a non-empty user table. 34 | yit "leaves the user table empty" $ do 35 | get HomeR 36 | statusIs 200 37 | users <- runDB $ selectList ([] :: [Filter User]) [] 38 | assertEqual "user table empty" 0 $ L.length users 39 | -------------------------------------------------------------------------------- /tests/TestImport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module TestImport 3 | ( module Yesod.Test 4 | , module Model 5 | , module Foundation 6 | , module Database.Persist 7 | , runDB 8 | , Spec 9 | , Example 10 | ) where 11 | 12 | import Yesod.Test 13 | import Database.Persist hiding (get) 14 | import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool) 15 | import Control.Monad.IO.Class (liftIO) 16 | 17 | import Foundation 18 | import Model 19 | 20 | type Spec = YesodSpec App 21 | type Example = YesodExample App 22 | 23 | runDB :: SqlPersistM a -> Example a 24 | runDB query = do 25 | pool <- fmap connPool getTestYesod 26 | liftIO $ runSqlPersistMPool query pool 27 | -------------------------------------------------------------------------------- /tests/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Main where 6 | 7 | import Import 8 | import Yesod.Default.Config 9 | import Yesod.Test 10 | import Test.Hspec (hspec) 11 | import Application (makeFoundation) 12 | 13 | import HomeTest 14 | 15 | main :: IO () 16 | main = do 17 | conf <- Yesod.Default.Config.loadConfig $ (configSettings Testing) 18 | { csParseExtra = parseExtra 19 | } 20 | foundation <- makeFoundation conf 21 | hspec $ do 22 | yesodSpec foundation $ do 23 | homeSpecs 24 | --------------------------------------------------------------------------------