├── .ghci ├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── TODO ├── cabal.config ├── cabal.config.ghc-7.4 ├── changelog.md ├── devel.cfg ├── robots.txt ├── scripts ├── dev.lbs ├── migrate │ ├── Makefile │ ├── Setup.hs │ ├── migrate.cabal │ └── migrate.hs ├── mongo-backup.sh └── mongo.js ├── snap-web.cabal ├── snaplets ├── heist │ └── templates │ │ ├── _delete-reply.tpl │ │ ├── _google-a.tpl │ │ ├── _layout-css-prod.tpl │ │ ├── _layout-css.tpl │ │ ├── _layout-footer.tpl │ │ ├── _layout-js-prod.tpl │ │ ├── _layout-js.tpl │ │ ├── _layout-nav.tpl │ │ ├── _markdown-input.tpl │ │ ├── _reply-author.tpl │ │ ├── _simple-signup-fields.tpl │ │ ├── _single-tag.tpl │ │ ├── _topic-author.tpl │ │ ├── about.md │ │ ├── about.tpl │ │ ├── error-page.tpl │ │ ├── forgot-password.tpl │ │ ├── index.tpl │ │ ├── layout.tpl │ │ ├── reply-to-form.tpl │ │ ├── reply-to-reply-detail.tpl │ │ ├── reply-to-reply-form.tpl │ │ ├── signin.tpl │ │ ├── signup.tpl │ │ ├── study.md │ │ ├── study.tpl │ │ ├── tag-list.tpl │ │ ├── topic-detail.tpl │ │ ├── topic-form.tpl │ │ ├── topic-preview.tpl │ │ ├── user-detail.tpl │ │ └── user-form.tpl └── i18n │ ├── message-en_US.cfg │ └── message-zh_CN.cfg ├── src ├── Application.hs ├── Controllers │ ├── Exception.hs │ ├── Feed.hs │ ├── Home.hs │ ├── Reply.hs │ ├── Routes.hs │ ├── Site.hs │ ├── Tag.hs │ ├── Topic.hs │ └── User.hs ├── Data │ ├── Baeson │ │ └── Types.hs │ └── Time │ │ └── Relative.hs ├── Main.hs ├── Models │ ├── Exception.hs │ ├── Feed.hs │ ├── Internal │ │ ├── Exception.hs │ │ ├── JSON.hs │ │ └── Types.hs │ ├── Reply.hs │ ├── Tag.hs │ ├── Topic.hs │ ├── User.hs │ └── Utils.hs ├── Snap │ └── Snaplet │ │ ├── Auth │ │ └── Backends │ │ │ └── MongoDB.hs │ │ └── Environments.hs ├── Text │ └── Digestive │ │ ├── FormExt.hs │ │ └── HeistExt.hs └── Views │ ├── Feed.hs │ ├── MarkdownSplices.hs │ ├── PaginationSplices.hs │ ├── ReplyForm.hs │ ├── ReplySplices.hs │ ├── SharedSplices.hs │ ├── TagSplices.hs │ ├── TopicForm.hs │ ├── TopicSplices.hs │ ├── Types.hs │ ├── UserForm.hs │ ├── UserSplices.hs │ └── Utils.hs ├── static ├── bootstrap │ ├── alerts.less │ ├── badges.less │ ├── bootstrap.less │ ├── breadcrumbs.less │ ├── button-groups.less │ ├── buttons.less │ ├── carousel.less │ ├── close.less │ ├── code.less │ ├── component-animations.less │ ├── dropdowns.less │ ├── forms.less │ ├── glyphicons.less │ ├── grid.less │ ├── input-groups.less │ ├── jumbotron.less │ ├── labels.less │ ├── list-group.less │ ├── media.less │ ├── mixins.less │ ├── mixins │ │ ├── alerts.less │ │ ├── background-variant.less │ │ ├── border-radius.less │ │ ├── buttons.less │ │ ├── center-block.less │ │ ├── clearfix.less │ │ ├── forms.less │ │ ├── gradients.less │ │ ├── grid-framework.less │ │ ├── grid.less │ │ ├── hide-text.less │ │ ├── image.less │ │ ├── labels.less │ │ ├── list-group.less │ │ ├── nav-divider.less │ │ ├── nav-vertical-align.less │ │ ├── opacity.less │ │ ├── pagination.less │ │ ├── panels.less │ │ ├── progress-bar.less │ │ ├── reset-filter.less │ │ ├── resize.less │ │ ├── responsive-visibility.less │ │ ├── size.less │ │ ├── tab-focus.less │ │ ├── table-row.less │ │ ├── text-emphasis.less │ │ ├── text-overflow.less │ │ └── vendor-prefixes.less │ ├── modals.less │ ├── navbar.less │ ├── navs.less │ ├── normalize.less │ ├── pager.less │ ├── pagination.less │ ├── panels.less │ ├── popovers.less │ ├── print.less │ ├── progress-bars.less │ ├── responsive-embed.less │ ├── responsive-utilities.less │ ├── scaffolding.less │ ├── tables.less │ ├── theme.less │ ├── thumbnails.less │ ├── tooltip.less │ ├── type.less │ ├── utilities.less │ ├── variables.less │ └── wells.less ├── favicon.ico ├── hcn │ ├── hcn.code.less │ ├── hcn.core.less │ ├── hcn.less │ ├── hcn.main.less │ ├── hcn.markdown.less │ ├── hcn.responsive.less │ └── hcn.topic.reply.less ├── img │ └── cc.png ├── js │ ├── libs │ │ ├── bootstrap-button.js │ │ ├── bootstrap-collapse.js │ │ ├── bootstrap-transition.js │ │ └── jquery.js │ ├── markdown.js │ ├── topic-form.js │ └── topic.js └── lessjs │ ├── less-1.3.0.min.js │ └── less-1.7.0.min.js └── tests ├── Controllers ├── TagsTest.hs └── Tests.hs ├── TestSuite.hs └── Views ├── PaginationSplicesTest.hs ├── ReplySplicesTest.hs └── Tests.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -hide-package MonadCatchIO-mtl 3 | :set -hide-package monads-fd 4 | :set -XOverloadedStrings 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | log/*.log 3 | tmp* 4 | _backup 5 | _site 6 | log 7 | data/*.txt 8 | data/auth.json 9 | data/env.cfg 10 | report.html 11 | cabal-dev* 12 | 13 | .cabal-sandbox 14 | cabal.sandbox.config 15 | .tern-port 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | ghc: 7.4 3 | notifications: 4 | email: false 5 | before_install: 6 | - "cp cabal.config.ghc-7.4 cabal.config" 7 | install: 8 | - "make init" 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, Haisheng Wu 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 Haisheng Wu 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ## DOCKER 2 | ## docker run -it -p 9900:9900 --workdir=/root/snap-web freizl/snap-web-ghc7.4:v3 /bin/bash 3 | ## 4 | 5 | CBD=cabal 6 | STYLE=stylish-haskell 7 | 8 | PROG_PREV = ./dist/build/snap-web/snap-web 9 | PROD_PROD = .cabal-sandbox/bin/snap-web 10 | PROG_NAME = ./snap-web 11 | 12 | DIST=dist 13 | SITE=_site 14 | 15 | default: build 16 | 17 | clean: 18 | cabal clean 19 | 20 | hlint: 21 | $(STYLE) -i src/**/*.hs 22 | hlint src/ tests/ --report=$(DIST)/hlint.html 23 | 24 | doc: 25 | cabal haddock --executable 26 | 27 | 28 | ########################### 29 | ## DEVELOPMENT 30 | ## 31 | ########################### 32 | 33 | ## need manual config pandoc because of https://github.com/jgm/pandoc/issues/1526 34 | ## 35 | init: 36 | test -e cabal.sandbox.config || $(CBD) sandbox init 37 | cabal install -fthree transformers-compat 38 | cabal install scientific-0.3.2.1 -f -bytestring-builder 39 | mkdir data log 40 | $(CBD) install --only-dependencies --enable-tests --job=2 41 | 42 | conf: 43 | $(CBD) --flags="development" configure 44 | 45 | build: conf 46 | $(CBD) build 47 | 48 | install: conf 49 | $(CBD) install 50 | 51 | test: 52 | $(CBD) --flags="development" --enable-tests configure 53 | $(CBD) build 54 | $(CBD) test 55 | 56 | p: 57 | $(PROG_PREV) -p 9900 58 | 59 | cb: clean build 60 | 61 | bp: build p 62 | 63 | rp: clean build p 64 | 65 | ########################### 66 | ## PRODUCTION 67 | ## 68 | ########################### 69 | 70 | LOG_FILE=./log/build.log 71 | 72 | build-prod: clean 73 | echo "Start building" >$(LOG_FILE) 74 | date >>$(LOG_FILE) 75 | $(CBD) configure 76 | $(CBD) install 1>>$(LOG_FILE) 2>&1 77 | date >>$(LOG_FILE) 78 | echo "End building" >>$(LOG_FILE) 79 | 80 | rebuild: clean build-prod 81 | 82 | ## 83 | ## 1. create new dir _sites 84 | ## 2. compress HTML 85 | ## 3. combine & compress JS; replace related links in templates. 86 | ## 4. generate main.css via lessc; replace related links in templates. 87 | ## 5. [ ] md5sum 88 | ## 89 | 90 | JS_FILES=jquery.js bootstrap-collapse.js bootstrap-button.js 91 | 92 | create-site: 93 | rm -rf $(SITE) 94 | mkdir -p $(SITE)/log 95 | mkdir -p $(SITE)/static/css 96 | cp Makefile $(SITE)/ 97 | cp devel.cfg $(SITE)/prod.cfg 98 | cp robots.txt $(SITE)/static/ 99 | cp -r snaplets data $(SITE) 100 | cp -r static/img $(SITE)/static/img 101 | cp -r static/js $(SITE)/static/js 102 | 103 | cd $(SITE)/static/js && for x in *.js ; do \ 104 | uglifyjs $$x > $$x.min.js ; \ 105 | mv -f $$x.min.js $$x ; \ 106 | done 107 | 108 | # uglifyjs $$x > $$x.min.js 109 | # mv -f $$x.min.js $$x 110 | 111 | cd $(SITE)/static/js/libs && for x in $(JS_FILES) ; do \ 112 | uglifyjs $$x >> m.js ; \ 113 | rm -f $$x ;\ 114 | done 115 | 116 | mv -f $(SITE)/snaplets/heist/templates/_layout-js-prod.tpl $(SITE)/snaplets/heist/templates/_layout-js.tpl 117 | 118 | lessc --compress static/bootstrap/bootstrap.less > $(SITE)/static/css/main.css 119 | mv -f $(SITE)/snaplets/heist/templates/_layout-css-prod.tpl $(SITE)/snaplets/heist/templates/_layout-css.tpl 120 | 121 | for x in `find $(SITE)/ -name '*.tpl' ` ; do \ 122 | perl -i -p -e 's/[\r\n]+|[ ]{2}|//gs' $$x ; \ 124 | done 125 | 126 | cp $(PROD_PROD) $(SITE) 127 | 128 | 129 | prod: 130 | cd $(SITE) && $(PROG_NAME) -p 9900 -e prod 131 | 132 | ## ?? TODO: use --address=a.haskellcn.org 133 | a.hcn: 134 | $(PROG_NAME) -p 9900 -e prod --no-access-log 135 | 136 | 137 | ####################### 138 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | The site used this project: 2 | 3 | # Travis CI 4 | 5 | - master [![master](https://secure.travis-ci.org/HaskellCNOrg/snap-web.png?branch=master)](http://travis-ci.org/HaskellCNOrg/snap-web) 6 | - branch/0.3.0 [![branch-0.2](https://secure.travis-ci.org/HaskellCNOrg/snap-web.png?branch=branch/0.3.0)](http://travis-ci.org/HaskellCNOrg/snap-web) 7 | 8 | # Installation 9 | 10 | **Assume OS is \*inux with make otherwise figure out yourself by reading Makefile** 11 | 12 | 0. Install MongoDB 13 | 1. Install snap-web 14 | 15 | ``` 16 | git clone git://github.com/HaskellCNOrg/snap-web.git 17 | cd snap-web 18 | make init bp 19 | ``` 20 | 21 | 2. Open browser to 22 | 23 | # Production Deployment 24 | 25 | 0. Assume have done all steps in Installation section 26 | 1. install `nodejs`; 27 | 2. `npm -g install less ugilifyjs` 28 | 3. cd snap-web and `make create-site` 29 | 4. **Important** update `_site/prod.cfg` per your env. 30 | 31 | *All required files will be copy into _site folder, read make task for detail* 32 | 33 | ## Notes 34 | 35 | 1. Customization files 36 | - `prod.cfg`, `devel.cfg` 37 | 38 | # License 39 | 40 | Check the LICENSE file 41 | 42 | # Contribute 43 | 44 | Feel free ask questiones and contribute. 45 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | ## 0.1 2 | - User Registration 3 | - Add/Update New Posts 4 | - Add Comment to either a Topic or Comment 5 | - Pagination for Posts 6 | - i18n support 7 | 8 | ## 0.2 9 | - Add tag per topic 10 | - Literature Haskell 11 | - XSS 12 | - enable Math support 13 | - UI change 14 | 15 | ## 0.3 16 | 17 | - upgrade snap-0.13 18 | - upgrade bootstrap 19 | - a few changes for SEO 20 | -------------------------------------------------------------------------------- /devel.cfg: -------------------------------------------------------------------------------- 1 | 2 | ### workaround since CPP does not work 3 | ## Deprecated 4 | #env = "devel" 5 | 6 | ### ENV Specified Config 7 | 8 | db { 9 | host = "127.0.0.1" 10 | ##collection = "haskellcn-mongodb" 11 | collection = "snap_web_db" 12 | batchSize = 500 13 | } 14 | 15 | feed { 16 | topicMax = 50 17 | commentMax = 100 18 | } 19 | 20 | pagesize = 15 21 | 22 | snaplet { 23 | session-key = "data/snaplet.cookie.session.txt" 24 | message-locale = "zh_CN" 25 | } 26 | 27 | auth { 28 | ## how to multiple? 29 | admin-role = "admin" 30 | minPasswordLen = 8 31 | siteKey = "./data/snaplet.auth.sitekey.txt" 32 | ##authCollection = "auth_user" 33 | } 34 | -------------------------------------------------------------------------------- /robots.txt: -------------------------------------------------------------------------------- 1 | user-agent: * 2 | Disallow: /user 3 | Disallow: /signin 4 | Disallow: /signup 5 | Disallow: /topic 6 | Allow: /topic/ 7 | -------------------------------------------------------------------------------- /scripts/dev.lbs: -------------------------------------------------------------------------------- 1 | ~~~~~ 2 | 3 | 4 | 5 | 6 | 7 | ~~~~~ 8 | 9 | 10 | **FAILED: because Pure is not visiable** 11 | 12 | -- | tags are separated by space in a string, thus needs split. 13 | -- 14 | extractTags :: Text -> [Text] 15 | extractTags = T.words 16 | 17 | tags .: textList extractTags (checkRequired "Tags is required" $ text Nothing) 18 | tags :: [T.Text] 19 | 20 | --textList :: Formlet v m [a] 21 | ----textList def = Pure Nothing $ Text $ fromMaybe [] def 22 | --textList = generalRead (fromMaybe []) 23 | -- 24 | --generalRead :: Monad a => (Maybe a -> a) -> Formlet v m a 25 | --generalRead f = Pure Nothing . Text . f 26 | 27 | 28 | ~~~~~ 29 | 30 | 31 | 39 | 40 | 41 | ~~~~ 42 | -------------------------------------------------------------------------------- /scripts/migrate/Makefile: -------------------------------------------------------------------------------- 1 | 2 | CBD=cabal-dev 3 | sandbox=--sandbox=../../cabal-dev 4 | 5 | default: build 6 | 7 | clean: 8 | rm -rf dist 9 | rm -rf cabal-dev 10 | 11 | build: 12 | $(CBD) $(sandbox) configure 13 | $(CBD) $(sandbox) build 14 | 15 | migrate: 16 | ./dist/build/migrate/migrate 17 | -------------------------------------------------------------------------------- /scripts/migrate/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /scripts/migrate/migrate.cabal: -------------------------------------------------------------------------------- 1 | -- Initial migrate.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: migrate 5 | version: 0.1.0.0 6 | build-type: Simple 7 | cabal-version: >=1.8 8 | 9 | Executable migrate 10 | Hs-source-dirs: ./ 11 | Main-is: migrate.hs 12 | Ghc-options: -Wall -i../../src -fno-warn-unused-do-bind 13 | Build-depends: 14 | -- duplicated from snap-web.cabal 15 | base >= 4 && < 5, 16 | bson >= 0.1.7 && < 0.2.2, 17 | compact-string-fix >= 0.3 && < 0.4, 18 | pwstore-fast >= 2.2, 19 | bson >= 0.1.7 && < 0.2.2, 20 | bytestring >= 0.9.1 && < 0.12, 21 | containers >= 0.4 && < 0.6, 22 | mongoDB >= 1.3 && < 2.0, 23 | mtl >= 2 && < 3, 24 | text >= 0.11 && < 0.12, 25 | time >= 1.1 && < 1.5 26 | 27 | -------------------------------------------------------------------------------- /scripts/migrate/migrate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Data.ByteString (ByteString) 6 | import Database.MongoDB 7 | import qualified Data.Text as T 8 | import qualified Data.Text.Encoding as T 9 | import Data.Baeson.Types 10 | import Crypto.PasswordStore 11 | import System.IO.Unsafe 12 | import System.Environment 13 | 14 | main :: IO () 15 | main = run 16 | 17 | run :: IO () 18 | run = do 19 | args <- getArgs 20 | let target = if null args then "test-migrate-nodeclub" else head args 21 | from = "node_club_backup" 22 | pipe <- runIOE $ connect (host "127.0.0.1") 23 | let dbNodeClub = accessNodeClub pipe from 24 | dbTarget = accessHaskellCN pipe (T.pack target) 25 | u <- dbNodeClub findNodeUser 26 | t <- dbNodeClub findNodeTopic 27 | r <- dbNodeClub findNodeReply 28 | dbTarget clearAll 29 | let datas = ( either (const []) id u 30 | , either (const []) id t 31 | , either (const []) id r) 32 | dbTarget (doMigrate datas) 33 | close pipe >> putStrLn "done" 34 | 35 | accessNodeClub pipe = access pipe slaveOk 36 | accessHaskellCN pipe = access pipe slaveOk 37 | 38 | doMigrate (usr, t, r) = do 39 | let (xs, ys) = migUsers usr 40 | insertMany "users" xs 41 | insertMany "auth_user" ys 42 | insertMany "topics" t 43 | insertMany "replies" r 44 | --where ts = map (merge ["tags" := Null]) t 45 | 46 | clearAll :: Action IO () 47 | clearAll = 48 | delete (select [] "users") 49 | >> delete (select [] "auth_user") 50 | >> delete (select [] "topics") 51 | >> delete (select [] "replies") 52 | 53 | migUsers :: [Document] -> ([Document], [Document]) 54 | migUsers docs = (xs, ys) 55 | where xs = map (map m1 . include ["_id", "name", "email", "url"]) docs 56 | ys = map (mergeys . map m2 . password' . include ["_id", "email", "create_at", "update_at"]) docs 57 | -- ++ 58 | -- (map (map password' . include ["email"]) docs) 59 | m1 field = case field of 60 | ("name" := v) -> "display_name" := v 61 | x -> x 62 | m2 field = case field of 63 | ("email" := v) -> ("email" := v) 64 | ("create_at" := v) -> ("createdAt" := v) 65 | ("update_at" := v) -> ("updatedAt" := v) 66 | x -> x 67 | mergeys = merge ysOthers 68 | ysOthers = [ "activatedAt" := Null 69 | , "suspendedAt" := Null 70 | , "rememberToken" := Null 71 | , "loginCount" .= (0 :: Int) 72 | , "userFailedLoginCount" .= (0 :: Int) 73 | , "lockedOutUntil" := Null 74 | , "currentLoginAt" := Null 75 | , "lastLoginAt" := Null 76 | , "currentLoginIp" := Null 77 | , "lastLoginIp" := Null 78 | , "roles" := Array [] 79 | ] 80 | password' fields = let email = head $ include ["email"] fields 81 | pass = mkp2 email 82 | login = makeLogin email 83 | in 84 | fields ++ [pass, login] 85 | makeLogin ("email" := v) = ("login" := v) 86 | 87 | mkp :: ByteString -> ByteString 88 | mkp passwd = unsafePerformIO $ makePassword passwd 12 89 | 90 | -- | use email as default password 91 | -- 92 | mkp2 :: Field -> Field 93 | mkp2 (_ := String v) = "password" := (Bin $ Binary $ mkp $ T.encodeUtf8 v) 94 | 95 | ---------------------------------------------------------------------- 96 | 97 | findNodeUser :: Action IO [Document] 98 | findNodeUser = rest =<< find (select [] "users") 99 | 100 | findNodeTopic :: Action IO [Document] 101 | findNodeTopic = rest =<< find (select [] "topics") 102 | 103 | findNodeReply :: Action IO [Document] 104 | findNodeReply = rest =<< find (select [] "replies") 105 | -------------------------------------------------------------------------------- /scripts/mongo-backup.sh: -------------------------------------------------------------------------------- 1 | ## back haskellcn 2 | haskellcn () 3 | { 4 | mongoexport --db snap_web_db --collection users -out users.json 5 | mongoexport --db snap_web_db --collection auth_user -out auth_user.json 6 | mongoexport --db snap_web_db --collection topics -out topics.json 7 | mongoexport --db snap_web_db --collection replies -out replies.json 8 | } 9 | 10 | ## backup nodeclub 11 | backfold=$(date +"%Y-%m-%d") 12 | rm -rf $backfold 13 | mkdir $backfold 14 | mongoexport --db snap_web_db --collection auth_user -out $backfold/nc-auth-user.json 15 | mongoexport --db snap_web_db --collection users -out $backfold/nc-users.json 16 | mongoexport --db snap_web_db --collection topics -out $backfold/nc-topics.json 17 | mongoexport --db snap_web_db --collection replies -out $backfold/nc-replies.json 18 | mongoexport --db snap_web_db --collection tags -out $backfold/nc-tags.json 19 | 20 | ## TODO Fixme 21 | doimport () 22 | { 23 | mongoimport --host 127.0.0.1 --port 27017 --db snap_web_db --collection auth_user -file nc-auth-user.json 24 | mongoimport --host 127.0.0.1 --port 27017 --db snap_web_db --collection users -file nc-users.json 25 | mongoimport --host 127.0.0.1 --port 27017 --db snap_web_db --collection topics -file nc-topics.json 26 | mongoimport --host 127.0.0.1 --port 27017 --db snap_web_db --collection replies -file nc-replies.json 27 | mongoimport --host 127.0.0.1 --port 27017 --db snap_web_db --collection tags -file nc-tags.json 28 | } 29 | -------------------------------------------------------------------------------- /scripts/mongo.js: -------------------------------------------------------------------------------- 1 | //MONGODB 2 | 3 | //The $in operator indicates a "where value in ..." expression. For expressions of the form x == a OR x == b, this can be represented as 4 | // { x : { $in : [ a, b ] } } 5 | 6 | // $set 7 | 8 | 9 | db.topics.find().forEach(function(data) { 10 | db.topics.update({_id:data._id}, {$set: {tags: []}}); 11 | }); 12 | 13 | 14 | db.users.find().forEach(function(data) { 15 | db.users.update({_id:data._id}, {$set: {active: true}}); 16 | }); 17 | 18 | db.auth_user.find({"login": "admin@test.com"}).forEach(function (data) { 19 | db.auth_user.update({_id:data._id}, {$set: {roles: ["admin"]}}); 20 | //$push 21 | }); 22 | db.auth_user.find({"login": "admin@test.com"}).forEach(function (data) { 23 | db.users.update({_id:data._id}, {$unset: {roles: ["admin"]}}); 24 | }); 25 | 26 | db.topics.remove(...) 27 | 28 | mongo --eval "db.dropDatabase()" 29 | mongo haskellcn-mongodb --eval "db.dropDatabase()" 30 | 31 | 32 | // ======================================== 33 | // mongo dump 34 | // TODO: JS APIs ?? 35 | var coll = ["users", "auth_user", "topics", "replies"]; 36 | 37 | // lets do it is shell; 38 | 39 | // ======================================== 40 | // Update certain fields 41 | 42 | b.replies.find({"topic_id": ObjectId("4f8de")}); 43 | 44 | db.replies.update( { "_id" : ObjectId("4f9") }, 45 | { $set: { 46 | "content" : "aaaaaaa" 47 | } 48 | } 49 | ); 50 | 51 | db.tags.remove({"_id" : ObjectId("5331a8ed98942416ea000070")}); 52 | -------------------------------------------------------------------------------- /snap-web.cabal: -------------------------------------------------------------------------------- 1 | Name: Snap-Web 2 | Version: 0.3.1 3 | Synopsis: snap web 4 | Description: 5 | A light weight forum in Snapframework 6 | . 7 | Real world site using this application: http://a.haskellcn.org 8 | . 9 | 10 | License: BSD3 11 | license-file: LICENSE 12 | Author: Haisheng,Wu 13 | Maintainer: freizl@gmail.com 14 | Stability: Experimental 15 | Category: Web 16 | Build-type: Simple 17 | Cabal-version: >=1.10 18 | tested-with: GHC >= 7.4.1 19 | Homepage: https://github.com/HaskellCNOrg/snap-web 20 | 21 | Source-Repository head 22 | Type: git 23 | Location: git://github.com/HaskellCNOrg/snap-web.git 24 | 25 | Flag development 26 | Description: Whether to build the server in development (interpreted) mode 27 | Default: False 28 | 29 | Executable snap-web 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | main-is: Main.hs 33 | 34 | Build-depends: 35 | base >= 4 && < 5, 36 | 37 | MonadCatchIO-transformers >= 0.3 && < 0.4, 38 | aeson >= 0.6 && < 0.7, 39 | bson >= 0.1.7 && < 0.2.2, 40 | bytestring >= 0.9.1 && < 0.12, 41 | case-insensitive >= 0.4.0.4 && < 0.5, 42 | clientsession >= 0.7.4 && < 1.0, 43 | compact-string-fix >= 0.3 && < 0.4, 44 | configurator >= 0.2 && < 0.3, 45 | containers >= 0.4 && < 0.6, 46 | mtl >= 2 && < 3, 47 | old-locale >= 1.0 && < 1.1, 48 | pandoc >= 1.9, 49 | resource-pool >= 0.2 && < 0.3, 50 | lens >= 3.7.0.1 && < 3.8, 51 | text >= 0.11 && < 1.2, 52 | time >= 1.1 && < 1.5, 53 | unordered-containers >= 0.2.3.0 && < 0.3, 54 | utf8-string >= 0.3.7 && < 0.4, 55 | mongoDB >= 1.3 && < 2.0, 56 | 57 | snap-loader-dynamic >= 0.9 && < 0.11, 58 | snap-loader-static >= 0.9 && < 0.11, 59 | blaze-builder >= 0.3.1.0 && < 0.4, 60 | digestive-functors >= 0.5 && < 1.0, 61 | digestive-functors-heist >= 0.5 && < 1.0, 62 | digestive-functors-snap >= 0.5 && < 1.0, 63 | heist >= 0.10 && < 0.14, 64 | snap >= 0.10 && < 0.14, 65 | snap-core >= 0.9 && < 0.14, 66 | snap-server >= 0.9 && < 0.14, 67 | snaplet-i18n >= 0.0.5 && < 0.1, 68 | snaplet-mongodb-minimalistic >= 0.0.6.6 && < 0.0.7, 69 | xmlhtml >= 0.2 && < 0.3, 70 | xss-sanitize >= 0.3.3 && < 0.4, 71 | 72 | -- Workaround for failing to link at wider version 73 | attoparsec >= 0.10 && < 0.12 74 | 75 | cpp-options: -DTIMEZONE=CST 76 | if flag(development) 77 | build-depends: 78 | snap-loader-dynamic >= 0.9 79 | cpp-options: -DDEVELOPMENT 80 | ghc-options: -threaded -w 81 | else 82 | if impl(ghc >= 6.12.0) 83 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 84 | -fno-warn-unused-do-bind -fno-spec-constr-count 85 | else 86 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 87 | 88 | Test-suite hcn-tests 89 | Type: exitcode-stdio-1.0 90 | Hs-source-dirs: tests 91 | Main-is: TestSuite.hs 92 | Ghc-options: -Wall -isrc 93 | Build-depends: 94 | HUnit >= 1.2 && < 1.3, 95 | test-framework >= 0.6 && < 0.7, 96 | test-framework-hunit >= 0.2 && < 0.3, 97 | -- Copied from regular dependencies: 98 | base >= 4 && < 5 99 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_delete-reply.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Yes 5 | No 6 | 7 | 8 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_google-a.tpl: -------------------------------------------------------------------------------- 1 | 14 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-css-prod.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-css.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-footer.tpl: -------------------------------------------------------------------------------- 1 | 2 |
3 | 13 | 14 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-js-prod.tpl: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-js.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_layout-nav.tpl: -------------------------------------------------------------------------------- 1 | 55 | 56 |
57 | 58 | Fork me on GitHub 59 | 60 |
61 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_markdown-input.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_reply-author.tpl: -------------------------------------------------------------------------------- 1 |

2 | 3 | 4 |

5 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_simple-signup-fields.tpl: -------------------------------------------------------------------------------- 1 |
2 | 3 |
4 | 5 |
6 |
7 | 8 |
9 | 10 |
11 | 12 |
13 |
14 | 15 |
16 | 17 |
18 | 19 |
20 |
21 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_single-tag.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /snaplets/heist/templates/_topic-author.tpl: -------------------------------------------------------------------------------- 1 |

2 | Submitted by 3 | 4 | 7 | 8 | at 9 | 10 |

11 | -------------------------------------------------------------------------------- /snaplets/heist/templates/about.md: -------------------------------------------------------------------------------- 1 | *Fans of Haskell* 2 | 3 | - [主站] 4 | - [微博] 5 | - [源代码] 6 | 7 | [主站]: http://www.haskellcn.org 8 | [微博]: http://weibo.com/haskellcnorg 9 | [源代码]: https://github.com/HaskellCNOrg/snap-web 10 | -------------------------------------------------------------------------------- /snaplets/heist/templates/about.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | -------------------------------------------------------------------------------- /snaplets/heist/templates/error-page.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 |

5 |

6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /snaplets/heist/templates/forgot-password.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 |
8 | 9 |
10 | 11 | 12 | 13 | 14 |
15 | 16 | 17 | 18 | 19 | 20 |
21 | 22 | 23 | 24 |
25 | 26 |
27 | 28 | 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /snaplets/heist/templates/index.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | 5 | 6 |
7 | 8 | 9 | 10 | 11 | 12 |

13 | 14 | 15 | 16 |
    17 | 18 |
  1. 19 | 20 | 21 |
    2. 22 |     23 |
24 |
25 | 26 |
27 | 28 |
29 | 30 |
31 | 32 | 33 | -------------------------------------------------------------------------------- /snaplets/heist/templates/layout.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | <i18n name="site.name" /> 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 |
31 | 32 | 33 |
34 | 35 | 36 | 37 | 38 | 39 | 40 | -------------------------------------------------------------------------------- /snaplets/heist/templates/reply-to-form.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | 5 |
6 | 7 | 8 |
9 | 10 |
11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /snaplets/heist/templates/reply-to-reply-detail.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | 5 | 6 |
7 | 8 | 9 | -------------------------------------------------------------------------------- /snaplets/heist/templates/reply-to-reply-form.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |
6 | 7 |
8 | 9 | 10 |
11 | 12 |
13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /snaplets/heist/templates/signin.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |
5 | 6 | 7 | 8 | 9 |
10 | 11 |
12 | 13 | 14 | 15 |
16 | 17 | 18 |
19 | 20 |
21 | 22 |
23 |
24 | 25 |
26 | 27 |
28 | 29 |
30 |
31 | 32 | 33 | 34 |
35 |
36 | 37 | 38 | 39 | 40 |
41 | 42 |
43 |
44 | 45 | 46 |
47 | 48 | 49 | 50 |

You already signin as

51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /snaplets/heist/templates/signup.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 |
6 | 7 | 8 | 9 |
10 | 11 |
12 | 13 | 14 | 15 |
16 | 17 | 18 | 19 | 20 |
21 |
22 | 23 | 24 | 25 |
26 |
27 |
28 | 29 | 30 |
31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /snaplets/heist/templates/study.md: -------------------------------------------------------------------------------- 1 | # Haskell 学习资源 2 | ## 课程 3 | 4 | - [Programming in Haskell](http://www.cs.nott.ac.uk/~gmh/book.html) 5 | - [INFORMATICS 1 – FUNCTIONAL PROGRAMMING by Phipl Wadler](http://www.youtube.com/playlist?list=PLey3KIETJDP-6dIBWfFWjKkz4AC88qN7t) 6 | - [CS240h: Functional Systems in Haskell](http://www.scs.stanford.edu/11au-cs240h/) 7 | - [CIS 552: Advanced Programming - Stephanie Weirich](http://www.seas.upenn.edu/~cis552/) 8 | - [Parallel Functional Programming - John Hughes](http://www.cse.chalmers.se/edu/course/pfp/index.html) 9 | - [Foundations of Computing Science](http://events.cs.bham.ac.uk/mgs2012/) 10 | - [CS 1501 Lectures - Introduction to Haskell by University of Virginia](http://shuklan.com/haskell/index.html) 11 | 12 | 13 | ## 演讲 14 | 15 | - [A Taste of Haskell - SPJ](http://blip.tv/oreilly-open-source-convention/oscon-2007-simon-peyton-jones-a-taste-of-haskell-part-i-329701) 16 | - [The Future is Parallel, and the Future of Parallel is Declarative - SPJ](http://yow.eventer.com/events/1004/talks/1055) 17 | - [Escape From the Ivory Tower - SPJ](http://yow.eventer.com/events/1004/talks/1054) 18 | - [High Performance concurrency - Simon Marlow](http://skillsmatter.com/podcast/home/high-performance-concurrency) 19 | 20 | ## 书籍 21 | 22 | - A Gentle Introduction to Haskell [英文](http://www.haskell.org/tutorial/) 23 | - Learn You a Haskell for Great Good [英文](http://learnyouahaskell.com/chapters) [中文](http://learnyouahaskell-zh-tw.csie.org/) 24 | - Real World Haskell [英文](http://book.realworldhaskell.org/) [中文](https://rwh.readthedocs.org/en/latest/) 25 | - Wiki Books/Haskell [英文](http://en.wikibooks.org/wiki/Haskell) [中文](http://zh.wikibooks.org/wiki/Haskell) 26 | - [Haskell函数式编程入门 by 张淞](http://book.douban.com/subject/25843224/) 27 | 28 | ## 论文 29 | - [Haisheng的收集](http://code.google.com/p/ipaper/) 30 | 31 | ## 更多(英文) 32 | - [学习资源](http://www.haskell.org/haskellwiki/Learning_Haskell) 33 | - [教程](http://www.haskell.org/haskellwiki/Tutorials) 34 | - [图书](http://www.haskell.org/haskellwiki/Books) 35 | - [论文](http://www.haskell.org/haskellwiki/Research_papers) 36 | -------------------------------------------------------------------------------- /snaplets/heist/templates/study.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /snaplets/heist/templates/tag-list.tpl: -------------------------------------------------------------------------------- 1 | 2 |

3 |
    4 | 5 |
  • 6 | 7 |
    • 8 |     9 |
10 | 11 | 12 | -------------------------------------------------------------------------------- /snaplets/heist/templates/topic-detail.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 |
5 |
    6 |
    • 7 |
8 |
9 | 10 | 11 | 12 | 13 | 14 |
15 | 16 |
17 |

18 |
19 |
20 | 21 | 22 | 23 |

24 | 25 | 26 | 27 |

28 | 29 | 30 | 31 |
32 | 33 | 34 | 35 |
36 | 37 | 38 | 39 | 40 |
41 |

42 | 43 |
44 |

45 | 46 | 47 |
48 | 49 |
50 | 51 | 52 | 53 | 54 | 55 | 56 |
57 | 58 | 59 |
60 | 61 |
62 | 63 | 64 |
65 |
66 |

67 | 68 |
69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /snaplets/heist/templates/topic-form.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | 5 | 6 | 7 | 8 |
9 | 10 | 11 |
12 | 13 | 14 |
15 | 16 |
17 | 18 |
19 |
20 | 21 |
22 | 23 | 24 | () 25 | 26 | 27 |
28 | 29 |
30 |
31 | 32 |
33 | 34 |
35 | 36 |
37 |
38 | 39 | 40 | 41 |
42 | 43 | 44 | 45 | 46 | 47 | 48 |
49 | 50 | 51 |
52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | -------------------------------------------------------------------------------- /snaplets/heist/templates/topic-preview.tpl: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /snaplets/heist/templates/user-detail.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 |

7 | : 8 | 9 |

10 | 11 | 12 |

13 | : 14 | 15 |

16 | 17 |

18 | : 19 | 20 |

21 | 22 | 23 |

24 | : 25 |

26 |

27 | : 28 |

29 | 30 | 31 | 32 |

33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /snaplets/heist/templates/user-form.tpl: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 | 5 | 6 | 7 | 8 |
9 | 10 |
11 | 12 | 13 |
14 | 15 |
16 | 17 |
18 |
19 | 20 |
21 | 22 |
23 | 24 |
25 |
26 | 27 | 28 | 29 |
30 |
31 | 32 | 33 | 34 |
35 |
36 | 37 | 38 |
39 | 40 | 41 | -------------------------------------------------------------------------------- /snaplets/i18n/message-en_US.cfg: -------------------------------------------------------------------------------- 1 | ## default message in English 2 | 3 | ## common 4 | site { 5 | about = "About" 6 | alias = "power by HaskellCN" 7 | delete = "Delete" 8 | description = "Towards to Web with Haskell" 9 | edit = "Edit" 10 | keywords = "Haskell" 11 | name = "Towards to Web with Haskell" 12 | no = "No" 13 | study = "study" 14 | yes = "Yes" 15 | haskellnews = "Haskell News" 16 | markdownHelper = "markdown syntax" 17 | } 18 | 19 | feed { 20 | topic { 21 | title = "HaskellCNOrg Topics" 22 | } 23 | comment { 24 | title = "HaskellCNOrg Comments" 25 | } 26 | } 27 | 28 | ## Registration 29 | user { 30 | createdSince = "User Created Since" 31 | detailHeader = "User Details" 32 | displayName = "Display Name" 33 | email = "Email Addr." 34 | forgotPassword = "Forgot password" 35 | lastLogin = "Last Login" 36 | login = "Login" 37 | password = "Password" 38 | repeatEmail = "Repeat Email" 39 | repeatPassword = "Repeat Password" 40 | requiredLoginname = "loginName is required" 41 | requiredPassword = "Password is required" 42 | resetPassword = "Reset password" 43 | signin = "Sign in" 44 | signout = "Sign out" 45 | signup = "Sign up" 46 | siteUrl = "User Site" 47 | submit = "Save" 48 | userName = "Username" 49 | } 50 | 51 | ## Topic 52 | 53 | topic { 54 | answers = "Answers" 55 | content = "Topic Content" 56 | empty = "No topic found" 57 | listHeader = "Topics List" 58 | new = "New Topic" 59 | preview = "Preview" 60 | submit = "Topic Submit" 61 | tag = "Tags" 62 | title = "Topic Title" 63 | } 64 | 65 | ## Comments 66 | reply { 67 | add = "Add Reply" 68 | 69 | reply { 70 | add = "Add Comment" 71 | submit = "Add" 72 | } 73 | 74 | cancel = "Cancel" 75 | } 76 | 77 | ## Tag 78 | 79 | tag { 80 | list = "All tags" 81 | listHeader = "All Tags" 82 | } 83 | 84 | error { 85 | title = "Server Error" 86 | } 87 | 88 | -------------------------------------------------------------------------------- /snaplets/i18n/message-zh_CN.cfg: -------------------------------------------------------------------------------- 1 | ## default message in English 2 | 3 | ## common 4 | site { 5 | about = "关于" 6 | alias = "HaskellCN" 7 | delete = "删除" 8 | description = "Haskell 中文社区" 9 | edit = "编辑" 10 | keywords = "Haskell 中文社区, Haskell China, Haskell Chinese Community, Haskell中文" 11 | name = "Haskell 中文社区" 12 | no = "否" 13 | study = "学习资料" 14 | yes = "是" 15 | haskellnews = "新闻" 16 | markdownHelper = "输入语法帮助" 17 | } 18 | 19 | feed { 20 | topic { 21 | title = "Haskell 中文社区 - 话题" 22 | } 23 | comment { 24 | title = "Haskell 中文社区 - 回复" 25 | } 26 | } 27 | 28 | ## Registration 29 | user { 30 | createdSince = "账号新建于" 31 | detailHeader = "用户信息" 32 | displayName = "昵称" 33 | email = "电子邮箱" 34 | forgotPassword = "忘记密码" 35 | lastLogin = "上次登录" 36 | login = "登录" 37 | password = "密码" 38 | repeatEmail = "重复邮箱" 39 | repeatPassword = "重复密码" 40 | requiredLoginname = "用户名不能为空" 41 | requiredPassword = "密码不能为空" 42 | resetPassword = "重置密码" 43 | signin = "登录" 44 | signout = "退出" 45 | signup = "注册" 46 | siteUrl = "个人主页" 47 | submit = "保存" 48 | userName = "用户名" 49 | } 50 | 51 | ## Topic 52 | 53 | topic { 54 | answers = "所有回复" 55 | content = "内容" 56 | empty = "No topic found" 57 | listHeader = "所有话题" 58 | new = "发表话题" 59 | preview = "预览" 60 | submit = "保存话题" 61 | tag = "标签" 62 | title = "标题" 63 | } 64 | 65 | ## Comments 66 | reply { 67 | add = "添加回复" 68 | 69 | reply { 70 | add = "添加评论" 71 | submit = "添加" 72 | } 73 | 74 | cancel = "取消" 75 | } 76 | 77 | ## Tag 78 | 79 | tag { 80 | list = "所有标签" 81 | listHeader = "所有标签" 82 | } 83 | 84 | error { 85 | title = "Server Error" 86 | } 87 | 88 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | This module defines our application's state type and an alias for its 5 | -- handler monad. 6 | -- 7 | module Application where 8 | 9 | ------------------------------------------------------------------------------ 10 | import Control.Lens 11 | import Snap.Snaplet 12 | import Snap.Snaplet.Auth 13 | import Snap.Snaplet.Heist 14 | import Snap.Snaplet.I18N 15 | import Snap.Snaplet.MongoDB.Core 16 | import Snap.Snaplet.Session 17 | 18 | ------------------------------------------------------------------------------ 19 | data App = App 20 | { _heist :: Snaplet (Heist App) 21 | , _i18n :: Snaplet I18N 22 | , _appSession :: Snaplet SessionManager 23 | , _appMongoDB :: Snaplet MongoDB 24 | , _appAuth :: Snaplet (AuthManager App) 25 | , _adminRole :: Role -- ^ Role for admin user. keep it simple for now. 26 | } 27 | 28 | makeLenses ''App 29 | 30 | instance HasHeist App where 31 | heistLens = subSnaplet heist 32 | 33 | instance HasI18N App where 34 | i18nLens = i18n 35 | 36 | instance HasMongoDB App where 37 | getMongoDB app = app ^. (appMongoDB . snapletValue) 38 | -- getMongoDB = (^& (appMongoDB . snapletValue)) 39 | 40 | ------------------------------------------------------------------------------ 41 | type AppHandler = Handler App App 42 | -------------------------------------------------------------------------------- /src/Controllers/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Controllers.Exception where 5 | 6 | import Data.ByteString (ByteString) 7 | import qualified Data.ByteString as BS 8 | import Data.Text (Text) 9 | import qualified Heist.Interpreted as I 10 | import Snap.Core 11 | import Snap.Snaplet 12 | import Snap.Snaplet.Heist 13 | 14 | import Application 15 | import Models.Exception 16 | import Models.Utils 17 | 18 | ------------------------------------------------------------------------------ 19 | 20 | routes :: [(ByteString, Handler App App ())] 21 | routes = [ ("", fourofourH) 22 | ] 23 | 24 | fourofourH :: AppHandler () 25 | fourofourH = do 26 | -- FIXME: this has been print twice. why?? 27 | -- liftIO $ print "error handler" 28 | modifyResponse (setResponseStatus 404 "Not Found") 29 | req <- getRequest 30 | toErrorPage . bsToText $ "No handler accepted " `BS.append` rqURI req 31 | r <- getResponse 32 | finishWith r 33 | 34 | 35 | exceptionH :: UserException -> AppHandler () 36 | exceptionH = toErrorPage . showUE 37 | 38 | 39 | toErrorPage :: Text -- ^ Errors 40 | -> AppHandler () 41 | toErrorPage err = heistLocal (I.bindSplice "error" (I.textSplice err)) $ render "error-page" 42 | -------------------------------------------------------------------------------- /src/Controllers/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Controllers.Feed 5 | where 6 | 7 | --import Control.Monad (mapM) 8 | import qualified Data.ByteString as BS 9 | import Snap.Core (writeBuilder) 10 | import Snap.Snaplet (Handler) 11 | import Snap.Snaplet.Environments 12 | 13 | import Application 14 | import Models.Feed 15 | import Models.Reply 16 | import Models.Topic 17 | import Views.Feed 18 | 19 | 20 | routes :: [(BS.ByteString, Handler App App ())] 21 | routes = [ ("/feed/topic", topicFeed) 22 | , ("/rss", topicFeed) 23 | , ("/feed/comment", commentFeed) 24 | ] 25 | 26 | 27 | -- | Atom feed of topics. 28 | -- 29 | topicFeed :: AppHandler () 30 | topicFeed = do 31 | count <- lookupConfigDefault "feed.topicMax" 20 32 | topics <- findAllTopic 33 | feed <- topicToFeed $ take count topics 34 | writeBuilder $ renderFeed feed 35 | 36 | 37 | -- | Atom feed of comments. 38 | -- 39 | commentFeed :: AppHandler () 40 | commentFeed = do 41 | count <- lookupConfigDefault "feed.commentMax" 20 42 | replys <- findAllReply 43 | feed <- replyToFeed $ take count replys 44 | writeBuilder $ renderFeed feed 45 | -------------------------------------------------------------------------------- /src/Controllers/Home.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Controllers.Home where 5 | 6 | import Application 7 | import Data.ByteString (ByteString) 8 | import qualified Heist.Interpreted as I 9 | import Snap.Core 10 | import Snap.Snaplet 11 | import Snap.Snaplet.Heist 12 | 13 | import Models.Topic (findAllTopic) 14 | import Views.TopicSplices 15 | import Views.Utils 16 | 17 | ------------------------------------------------------------------------------ 18 | 19 | -- | Renders the front page of the sample site. 20 | -- 21 | index :: Handler App App () 22 | index = ifTop $ do 23 | page <- decodedParamNum "p" 24 | topics <- findAllTopic 25 | heistLocal (I.bindSplices $ topicSplices topics page) $ render "index" 26 | 27 | redirectToHome :: Handler App App () 28 | redirectToHome = redirect303 "/" 29 | 30 | redirect303 :: ByteString -> Handler App App () 31 | redirect303 url = redirect' url 303 32 | -------------------------------------------------------------------------------- /src/Controllers/Routes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Controllers.Routes 5 | ( routes 6 | ) where 7 | 8 | import Control.Applicative 9 | import Data.ByteString (ByteString) 10 | import Snap.Snaplet 11 | import Snap.Snaplet.Heist 12 | import Snap.Util.FileServe 13 | 14 | import Application 15 | import qualified Controllers.Exception as Ex 16 | import qualified Controllers.Feed as Feed 17 | import Controllers.Home 18 | import qualified Controllers.Reply as Reply 19 | import qualified Controllers.Tag as Tag 20 | import qualified Controllers.Topic as Topic 21 | import qualified Controllers.User as User 22 | 23 | routes :: [(ByteString, Handler App App ())] 24 | routes = [ ("/", index) 25 | , ("/index", index) 26 | ] 27 | <|> 28 | User.routes 29 | <|> 30 | Topic.routes 31 | <|> 32 | Reply.routes 33 | <|> 34 | Tag.routes 35 | <|> 36 | Feed.routes 37 | <|> 38 | [ ("", with heist heistServe) 39 | , ("", serveDirectory "static") 40 | ] 41 | <|> Ex.routes 42 | -------------------------------------------------------------------------------- /src/Controllers/Site.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | This module is where all the routes and handlers are defined for your 5 | -- site. The 'app' function is the initializer that combines everything 6 | -- together and is exported by this module. 7 | -- 8 | module Controllers.Site 9 | ( app 10 | ) where 11 | 12 | ------------------------------------------------------------------------------ 13 | 14 | import Control.Applicative ((<$>)) 15 | import Database.MongoDB (host) 16 | import Snap.Snaplet 17 | import Snap.Snaplet.Auth 18 | import Snap.Snaplet.Auth.Backends.MongoDB 19 | import Snap.Snaplet.Environments 20 | import Snap.Snaplet.Heist 21 | import Snap.Snaplet.I18N 22 | import Snap.Snaplet.MongoDB 23 | import Snap.Snaplet.Session.Backends.CookieSession 24 | 25 | ------------------------------------------------------------------------------ 26 | 27 | import Application 28 | import Controllers.Routes 29 | import Views.SharedSplices 30 | import Views.Utils 31 | 32 | ------------------------------------------------------------------------------ 33 | -- | The application initializer. 34 | 35 | app :: SnapletInit App App 36 | app = makeSnaplet "app" "Happy Haskell, Happy Snap." Nothing $ do 37 | ul <- lookupConfig "snaplet.message-locale" 38 | sk <- lookupConfigDefault "snaplet.session-key" "data/session-sitekey.txt" 39 | dbkey <- lookupConfigDefault "auth.siteKey" "data/auth-sitekey.txt" 40 | ar <- Role <$> lookupConfigDefault "auth.admin-role" "administrator" 41 | dbhost <- lookupConfigDefault "db.host" "127.0.0.1" 42 | dbc <- lookupConfigDefault "db.collection" "haskellcn-mongodb" 43 | 44 | h <- nestSnaplet "heist" heist $ heistInit "templates" 45 | i <- nestSnaplet "i18n" i18n $ initI18N ul 46 | s <- nestSnaplet "session" appSession $ cookieSessionMgr' sk 47 | d <- nestSnaplet "mongoDB" appMongoDB $ mongoDBInit 10 (host dbhost) dbc 48 | a <- nestSnaplet "auth" appAuth $ initMongoAuth appSession d (Just dbkey) 49 | 50 | addRoutes routes 51 | addAuthSplices h appAuth 52 | addSplices sharedSplices 53 | return $ App h i s d a ar 54 | where 55 | cookieSessionMgr' sk = initCookieSessionManager sk "myapp-session" (Just 600) 56 | 57 | 58 | ------------------------------------------------------------------------------ 59 | -------------------------------------------------------------------------------- /src/Controllers/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Controllers.Tag 5 | ( routes 6 | , saveTags 7 | , filterExistsTags 8 | ) where 9 | 10 | import Application 11 | import qualified Data.ByteString as BS 12 | import Data.List (deleteFirstsBy, nub) 13 | import qualified Data.Text as T 14 | import qualified Heist.Interpreted as I 15 | import Models.Tag 16 | import Snap 17 | import Snap.Snaplet.Heist 18 | import Views.TagSplices 19 | import Views.Utils 20 | 21 | ------------------------------------------------------------------------------ 22 | 23 | -- | Routes 24 | -- /tags -> get all tags 25 | -- 26 | routes :: [(BS.ByteString, Handler App App ())] 27 | routes = [ ("/tags", Snap.method GET getTagsH) 28 | ] 29 | 30 | tplTagList :: BS.ByteString 31 | tplTagList = "tag-list" 32 | 33 | ------------------------------------------------------------------------------ 34 | 35 | -- | Fetch all tags 36 | -- 37 | -- MAYBE: 1. if content-tye is not json, return empty 38 | -- 39 | getTagsH :: AppHandler () 40 | getTagsH = do 41 | req <- getRequest 42 | tags <- findAllTags 43 | let acceptJSON = hasAcceptHeaderJSON $ headers req 44 | if acceptJSON then toJSONResponse tags else 45 | heistLocal (I.bindSplice "tags" $ tagsSplice tags) $ render tplTagList 46 | 47 | ------------------------------------------------------------------------------ 48 | 49 | -- | Save a list of tags and return them getting ID has been insert. 50 | -- Perform save if is new otherwise ignore. 51 | -- 52 | -- 53 | saveTags :: [T.Text] -> AppHandler [Tag] 54 | saveTags input = do 55 | let input' = nub input 56 | xs <- findSomeTagsName input' 57 | ys <- mapM insertTag $ filterExistsTags (maybeNewTags input') xs 58 | return (xs ++ ys) 59 | where maybeNewTags = map textToTag 60 | textToTag name = emptyTag { _tagName = name } 61 | 62 | filterExistsTags :: [Tag] -- ^ Tags input from web 63 | -> [Tag] -- ^ Exists Tags per input 64 | -> [Tag] -- ^ Those new ones 65 | filterExistsTags = deleteFirstsBy eqName 66 | where eqName x y = _tagName x == _tagName y 67 | 68 | 69 | ---------------------------------------- 70 | -------------------------------------------------------------------------------- /src/Data/Time/Relative.hs: -------------------------------------------------------------------------------- 1 | {- 2 | THIS FILE IS COPY FROM PROJECT: https://github.com/chrisdone/haskellnews 3 | -} 4 | 5 | -- | Display times as a relative duration. E.g. x days ago. 6 | 7 | module Data.Time.Relative where 8 | 9 | import Data.List 10 | import Data.Time 11 | import Text.Printf 12 | 13 | -- | Display a time span as one time relative to another. 14 | relativeZoned :: ZonedTime -- ^ The later time span. 15 | -> ZonedTime -- ^ The earlier time span. 16 | -> Bool -- ^ Display 'in/ago'? 17 | -> String -- ^ Example: '3 seconds ago', 'in three days'. 18 | relativeZoned t1 t2 = 19 | relative (zonedTimeToUTC t1) (zonedTimeToUTC t2) 20 | 21 | -- | Display a time span as one time relative to another. 22 | relative :: UTCTime -- ^ The later time span. 23 | -> UTCTime -- ^ The earlier time span. 24 | -> Bool -- ^ Display 'in/ago'? 25 | -> String -- ^ Example: '3 seconds ago', 'in three days'. 26 | relative t1 t2 fix = maybe "unknown" format $ find (\(s,_,_) -> abs span>=s) $ reverse ranges where 27 | minute = 60; hour = minute * 60; day = hour * 24; 28 | week = day * 7; month = day * 30; year = month * 12 29 | format range = 30 | (if fix && span>0 then "in " else "") 31 | ++ case range of 32 | (_,str,0) -> str 33 | (_,str,base) -> printf str (abs $ round (span / base) :: Integer) 34 | ++ (if fix && span<0 then " ago" else "") 35 | span = t1 `diffUTCTime` t2 36 | ranges = [(0,"%d seconds",1) 37 | ,(minute,"a minute",0) 38 | ,(minute*2,"%d minutes",minute) 39 | ,(minute*30,"half an hour",0) 40 | ,(minute*31,"%d minutes",minute) 41 | ,(hour,"an hour",0) 42 | ,(hour*2,"%d hours",hour) 43 | ,(hour*3,"a few hours",0) 44 | ,(hour*4,"%d hours",hour) 45 | ,(day,"a day",0) 46 | ,(day*2,"%d days",day) 47 | ,(week,"a week",0) 48 | ,(week*2,"%d weeks",week) 49 | ,(month,"a month",0) 50 | ,(month*2,"%d months",month) 51 | ,(year,"a year",0) 52 | ,(year*2,"%d years",year) 53 | ] 54 | -------------------------------------------------------------------------------- /src/Models/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Models.Exception 4 | (module Models.Internal.Exception) 5 | where 6 | 7 | import Models.Internal.Exception 8 | 9 | -------------------------------------------------------------------------------- /src/Models/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Models.Feed 4 | where 5 | 6 | import Data.Maybe 7 | import qualified Data.Text as T 8 | import Data.Time (UTCTime) 9 | 10 | import Application 11 | import Models.Reply 12 | import Models.Topic 13 | import Models.User 14 | import Models.Utils (sToText) 15 | import Snap.Snaplet.I18N 16 | 17 | 18 | data Feed = Feed 19 | { feedTitle :: T.Text 20 | , feedLinkSelf :: T.Text 21 | , feedLinkHome :: T.Text 22 | , feedUpdated :: UTCTime 23 | , feedEntries :: [FeedEntry] 24 | } 25 | 26 | data FeedEntry = FeedEntry 27 | { feedEntryTitle :: T.Text 28 | , feedEntryLink :: T.Text 29 | , feedEntryId :: T.Text 30 | , feedEntryPublished :: UTCTime 31 | , feedEntryContent :: T.Text 32 | , feedEntryAuthorName :: T.Text 33 | , feedEntryAuthorUri :: T.Text 34 | } 35 | 36 | topicToFeed :: [Topic] -> AppHandler Feed 37 | topicToFeed ts = do 38 | entries <- mapM topicToFeedEntry ts 39 | feedTopicTitle <- lookupI18NValue "feed.topic.title" 40 | return 41 | Feed { feedTitle = feedTopicTitle 42 | -- TODO: retrieve host address here 43 | , feedLinkSelf = "/feed/topic" 44 | , feedLinkHome = "/" 45 | , feedUpdated = _updateAt $ head ts 46 | , feedEntries = entries 47 | } 48 | 49 | topicToFeedEntry :: Topic -> AppHandler FeedEntry 50 | topicToFeedEntry t = do 51 | u <- findOneUser $ _author t 52 | let authorId = sToText $ _author t 53 | return 54 | FeedEntry { feedEntryTitle = _title t 55 | , feedEntryLink = T.concat ["/topic/", getTopicId t] 56 | , feedEntryId = T.concat ["/topic/", getTopicId t] 57 | , feedEntryPublished = _createAt t 58 | , feedEntryContent = _content t 59 | , feedEntryAuthorName = _userDisplayName u 60 | , feedEntryAuthorUri = T.concat ["/user/", authorId] 61 | } 62 | 63 | replyToFeed :: [Reply] -> AppHandler Feed 64 | replyToFeed rs = do 65 | entries <- mapM replyToFeedEntry rs 66 | feedCommentTitle <- lookupI18NValue "feed.comment.title" 67 | return 68 | Feed { feedTitle = feedCommentTitle 69 | , feedLinkSelf = "/feed/comment" 70 | , feedLinkHome = "/" 71 | , feedUpdated = _replyCreateAt $ head rs 72 | , feedEntries = entries 73 | } 74 | 75 | replyToFeedEntry :: Reply -> AppHandler FeedEntry 76 | replyToFeedEntry r = do 77 | t <- findOneTopic $ _replyToTopicId r 78 | u <- findOneUser $ _replyAuthor r 79 | let authorId = sToText $ _replyAuthor r 80 | return 81 | FeedEntry { feedEntryTitle = T.concat ["Comment on ", _title t] 82 | , feedEntryLink = T.concat ["/topic/", getTopicId t] 83 | , feedEntryId = T.concat ["/topic/", getReplyId r] 84 | , feedEntryPublished = _replyCreateAt r 85 | , feedEntryContent = _replyContent r 86 | , feedEntryAuthorName = _userDisplayName u 87 | , feedEntryAuthorUri = T.concat ["/user/", authorId] 88 | } 89 | -------------------------------------------------------------------------------- /src/Models/Internal/Exception.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module Models.Internal.Exception where 4 | 5 | import Control.Monad.CatchIO (Exception (..), throw) 6 | import Control.Monad.Trans (MonadIO) 7 | import qualified Data.Text as T 8 | import Data.Typeable 9 | import Database.MongoDB (Failure (..)) 10 | 11 | data UserException = UserException String 12 | | PasswordTooShort Int 13 | | UserAlreadyExists 14 | deriving (Read, Eq, Show, Typeable) 15 | 16 | instance Exception UserException 17 | 18 | showUE :: UserException -> T.Text 19 | showUE (PasswordTooShort x) = T.pack $ "Password too short, at least " ++ show x 20 | showUE x = T.pack $ show x 21 | 22 | -- | Simply transform any Showable Exception to String and wrap into @UserException@ 23 | -- 24 | throwUE :: (Show s, MonadIO m) => s -> m a 25 | throwUE = throw . UserException . show 26 | 27 | -- | Transform MongoDB @Failure@ to customiable @UserException@. 28 | -- 29 | failureToUE :: (MonadIO m) => Failure -> m a 30 | failureToUE (DocNotFound _) = throw $ UserException "Document not Found." 31 | failureToUE e = throw . UserException $ show e 32 | -------------------------------------------------------------------------------- /src/Models/Internal/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Models.Internal.JSON where 4 | 5 | import Data.Aeson (ToJSON(..), Value(String)) 6 | import Data.Bson (ObjectId) 7 | import Models.Utils 8 | 9 | instance ToJSON ObjectId where 10 | toJSON = String . sToText 11 | -------------------------------------------------------------------------------- /src/Models/Tag.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Models.Tag where 5 | 6 | import Application 7 | import Control.Applicative ((<$>), (<*>)) 8 | import Control.Monad.CatchIO (throw) 9 | import Data.Aeson (ToJSON (..)) 10 | import qualified Data.Aeson as A 11 | import Data.Baeson.Types 12 | import Data.Bson 13 | import Data.Maybe (catMaybes) 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Database.MongoDB 17 | import Models.Internal.Exception 18 | import Models.Internal.Types 19 | import Models.Utils 20 | 21 | -- | Tag model 22 | -- 23 | data Tag = Tag 24 | { _tagId :: Maybe ObjectId 25 | , _tagName :: T.Text 26 | , _tagContent :: Maybe T.Text 27 | } deriving (Show, Eq) 28 | 29 | emptyTag :: Tag 30 | emptyTag = Tag Nothing "" Nothing 31 | 32 | -- | Schema name 33 | -- 34 | tagCollection :: Collection 35 | tagCollection = "tags" 36 | 37 | 38 | -------------------------------------------------------------------------------- 39 | -- Shortcuts 40 | -------------------------------------------------------------------------------- 41 | 42 | -- | Get Tag Id in {Text}. 43 | -- 44 | getTagId :: Tag -> T.Text 45 | getTagId = objectIdToText . _tagId 46 | 47 | toTagIds :: [Tag] -> Maybe [ObjectId] 48 | toTagIds = Just . catMaybes . fmap _tagId 49 | 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Impl of Persistent Interface 53 | -------------------------------------------------------------------------------- 54 | 55 | -- Impl 56 | -- 57 | instance MongoDBPersistent Tag where 58 | mongoColl _ = tagCollection 59 | toMongoDoc = tagToDocument 60 | fromMongoDoc = tagFromDocumentOrThrow 61 | mongoInsertId tag v = tag { _tagId = objectIdFromValue v } 62 | mongoGetId = _tagId 63 | 64 | -- | Transform @Tag@ to mongoDB document. 65 | -- Nothing of id mean new topic thus empty "_id" let mongoDB generate objectId. 66 | -- 67 | tagToDocument :: Tag -> Document 68 | tagToDocument tag = case _tagId tag of 69 | Nothing -> docs 70 | Just x -> ("_id" .= x) : docs 71 | where docs = [ "name" .= _tagName tag 72 | , "content" .= _tagContent tag 73 | ] 74 | 75 | -- | Transform mongo Document to be a Tag parser. 76 | -- 77 | documentToTag :: Document -> Parser Tag 78 | documentToTag d = Tag 79 | <$> d .: "_id" 80 | <*> d .: "name" 81 | <*> d .: "content" 82 | 83 | -- | parse the tag document 84 | -- 85 | tagFromDocumentOrThrow :: Document -> IO Tag 86 | tagFromDocumentOrThrow d = case parseEither documentToTag d of 87 | Left e -> throw $ UserException e 88 | Right r -> return r 89 | 90 | -------------------------------------------------------------------------------- 91 | -- CRUD 92 | -------------------------------------------------------------------------------- 93 | 94 | -- | Insert a new tag. 95 | -- meaning insert it if its new (has no "_id" field) or update it if its not new (has "_id" field) 96 | -- | FIXME: couple of thoughts: 97 | -- 2. batch create new tags? 98 | -- 99 | insertTag :: Tag -> AppHandler Tag 100 | insertTag = mongoInsert 101 | 102 | findAllTags :: AppHandler [Tag] 103 | findAllTags = mongoFindAll (undefined::Tag) 104 | 105 | findOneTag :: ObjectId -> AppHandler Tag 106 | findOneTag oid = mongoFindById $ emptyTag { _tagId = Just oid } 107 | 108 | findSomeTags :: [ObjectId] -> AppHandler [Tag] 109 | findSomeTags = mongoFindIds emptyTag 110 | 111 | -- | Notes: 112 | -- `map.textToS` is because T.Text is not a Val instance but Internal.Text and String. 113 | -- 114 | findSomeTagsName :: [Text] -> AppHandler [Tag] 115 | findSomeTagsName = mongoFindSomeBy "name" emptyTag . map textToS 116 | 117 | 118 | -------------------------------------------------------------------------------- 119 | -- Instances 120 | -------------------------------------------------------------------------------- 121 | 122 | instance ToJSON Tag where 123 | toJSON (Tag tid tname _) = A.object [ "id" A..= tid 124 | , "name" A..= tname 125 | ] 126 | -------------------------------------------------------------------------------- /src/Models/Topic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Models.Topic where 5 | 6 | import Control.Applicative ((<$>), (<*>)) 7 | import Control.Monad.CatchIO (throw) 8 | import Data.Baeson.Types 9 | import Data.Bson 10 | import qualified Data.Text as T 11 | import Data.Time (UTCTime) 12 | import Database.MongoDB 13 | 14 | import Application 15 | import Models.Internal.Exception 16 | import Models.Internal.Types 17 | import Models.Utils 18 | 19 | 20 | -- | 21 | -- 22 | data Topic = Topic 23 | { _topicId :: Maybe ObjectId 24 | , _title :: T.Text 25 | , _content :: T.Text 26 | , _author :: ObjectId 27 | , _createAt :: UTCTime 28 | , _updateAt :: UTCTime 29 | , _topicTags :: Maybe [ObjectId] 30 | } deriving (Show, Eq) 31 | 32 | topicCollection :: Collection 33 | topicCollection = "topics" 34 | 35 | getTopicId :: Topic -> T.Text 36 | getTopicId = objectIdToText . _topicId 37 | 38 | -- | A very empty @Topic@ 39 | -- 40 | emptyTopic :: Topic 41 | emptyTopic = Topic { _topicId = Nothing } 42 | 43 | 44 | -------------------------------------------------------------------------------- 45 | -- Impl of Persistent Interface 46 | -------------------------------------------------------------------------------- 47 | 48 | instance MongoDBPersistent Topic where 49 | mongoColl _ = topicCollection 50 | toMongoDoc = topicToDocument 51 | fromMongoDoc = topicFromDocumentOrThrow 52 | mongoInsertId topic v = topic { _topicId = objectIdFromValue v } 53 | mongoGetId = _topicId 54 | 55 | -- | Transform @Topic@ to mongoDB document. 56 | -- Nothing of id mean new topic thus empty "_id" let mongoDB generate objectId. 57 | -- 58 | topicToDocument :: Topic -> Document 59 | topicToDocument topic = case _topicId topic of 60 | Nothing -> docs 61 | Just x -> ("_id" .= x) : docs 62 | where docs = 63 | [ "title" .= _title topic 64 | , "content" .= _content topic 65 | , "author_id" .= _author topic 66 | , "create_at" .= _createAt topic 67 | , "update_at" .= _updateAt topic 68 | , "tags" .= _topicTags topic 69 | ] 70 | 71 | -- | Transform mongo Document to be a Topic parser. 72 | -- 73 | documentToTopic :: Document -> Parser Topic 74 | documentToTopic d = Topic 75 | <$> d .: "_id" 76 | <*> d .: "title" 77 | <*> d .: "content" 78 | <*> d .: "author_id" 79 | <*> d .: "create_at" 80 | <*> d .: "update_at" 81 | <*> d .:? "tags" 82 | 83 | -- | Parse the topic document 84 | -- 85 | topicFromDocumentOrThrow :: Document -> IO Topic 86 | topicFromDocumentOrThrow d = case parseEither documentToTopic d of 87 | Left e -> throw $ UserException e 88 | Right r -> return r 89 | 90 | 91 | 92 | -------------------------------------------------------------------------------- 93 | -- CRUD 94 | -------------------------------------------------------------------------------- 95 | 96 | 97 | -- | create a new topic. 98 | -- 99 | createNewTopic :: Topic -> AppHandler Topic 100 | createNewTopic = mongoInsert 101 | 102 | 103 | -- | save a new topic. 104 | -- 105 | saveTopic :: Topic -> AppHandler Topic 106 | saveTopic = mongoSave 107 | 108 | 109 | -- | Find One Topic by id. 110 | -- 111 | findOneTopic :: ObjectId -> AppHandler Topic 112 | findOneTopic oid = mongoFindById $ emptyTopic { _topicId = Just oid } 113 | 114 | 115 | -- | Find All Topic. 116 | -- 117 | findAllTopic :: AppHandler [Topic] 118 | findAllTopic = findTopicGeneric [] 119 | 120 | 121 | -- | Find topic per tag. 122 | -- 123 | findTopicByTag :: ObjectId -- ^ Tag ID 124 | -> AppHandler [Topic] 125 | findTopicByTag tagId = findTopicGeneric [ "tags" =: tagId ] 126 | 127 | 128 | -- | Even generic find handler 129 | -- 130 | findTopicGeneric :: Selector -> AppHandler [Topic] 131 | findTopicGeneric se = do 132 | let topicSelection = select se topicCollection 133 | mongoFindAllBy emptyTopic (topicSelection {sort = sortByCreateAtDesc}) 134 | 135 | 136 | -- | Order by CreateAt column DESC. 137 | -- 138 | sortByCreateAtDesc :: Order 139 | sortByCreateAtDesc = [ "create_at" =: -1 ] 140 | 141 | ------------------------------------------------------------------------------ 142 | -------------------------------------------------------------------------------- /src/Models/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | {- 4 | 5 | utils. 6 | 7 | -} 8 | 9 | module Models.Utils where 10 | 11 | ---------------------------------------------------------------- 12 | 13 | import Data.Bson (ObjectId, Value (..)) 14 | import qualified Data.Bson as BSON 15 | import qualified Data.ByteString as BS 16 | import qualified Data.ByteString.Lazy as LBS 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | 20 | ---------------------------------------------------------------- 21 | 22 | -- | Force Just "" to be Nothing. 23 | -- 24 | forceNonEmpty :: Maybe BS.ByteString -> Maybe BS.ByteString 25 | forceNonEmpty Nothing = Nothing 26 | forceNonEmpty (Just "") = Nothing 27 | forceNonEmpty x = x 28 | 29 | ---------------------------------------------------------------- 30 | 31 | textToS :: T.Text -> String 32 | textToS = T.unpack 33 | 34 | -- | Transform something which is instance of Show to Text. 35 | -- 36 | sToText :: Show s => s -> T.Text 37 | sToText = T.pack . show 38 | 39 | lbsToStrickBS :: LBS.ByteString -> BS.ByteString 40 | lbsToStrickBS = BS.concat . LBS.toChunks 41 | 42 | sToBS :: String -> BS.ByteString 43 | sToBS = T.encodeUtf8 . T.pack 44 | 45 | bsToS :: BS.ByteString -> String 46 | bsToS = T.unpack . T.decodeUtf8 47 | 48 | lbsToText :: LBS.ByteString -> T.Text 49 | lbsToText = T.decodeUtf8 . lbsToStrickBS 50 | 51 | textToBS :: T.Text -> BS.ByteString 52 | textToBS = T.encodeUtf8 53 | 54 | bsToText :: BS.ByteString -> T.Text 55 | bsToText = T.decodeUtf8 56 | 57 | ------------------------------------------------------------------------------ 58 | 59 | -- | FIXME: exception "no parse" if failed to convert. 60 | -- DEPRECATED to textToObjectIdMaybe 61 | -- 62 | textToObjectId :: T.Text -> ObjectId 63 | textToObjectId = read . textToS 64 | 65 | textToObjectIdMaybe :: T.Text -> Maybe ObjectId 66 | textToObjectIdMaybe = readMaybe . textToS 67 | 68 | readMaybe :: Read a => String -> Maybe a 69 | readMaybe s = case reads s of 70 | [(x, "")] -> Just x 71 | _ -> Nothing 72 | 73 | -- | Maybe ObjectId to Text 74 | -- 75 | objectIdToText :: Maybe ObjectId -> T.Text 76 | objectIdToText = maybe "" sToText 77 | 78 | -- | Case MongoDB.value to ObjectId 79 | -- 80 | objectIdFromValue :: Value -> Maybe ObjectId 81 | objectIdFromValue = BSON.cast' 82 | 83 | ------------------------------------------------------------------------------ 84 | 85 | -- | Split Text by space or comma and get ride of extra empty text. 86 | -- 87 | splitOnSpaceOrComma :: T.Text -> [T.Text] 88 | splitOnSpaceOrComma = filter (/= T.pack "") . T.split (\x -> x == ',' || x == ' ') 89 | -------------------------------------------------------------------------------- /src/Snap/Snaplet/Environments.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module Snap.Snaplet.Environments 6 | ( module Data.Configurator 7 | , lookupConfig 8 | , lookupConfigDefault 9 | ) 10 | where 11 | 12 | import Control.Monad.Reader 13 | import Data.Configurator 14 | import Data.Configurator.Types 15 | import Data.Maybe (fromMaybe) 16 | import Snap.Snaplet 17 | 18 | 19 | ----------------------------------------------------------- 20 | -- 21 | 22 | -- | Lookup for a config value 23 | -- 24 | lookupConfig :: (MonadIO (m b v), MonadSnaplet m, Configured a) => Name -> m b v (Maybe a) 25 | lookupConfig name = do 26 | config <- getSnapletUserConfig 27 | liftIO $ Data.Configurator.lookup config name 28 | 29 | -- | Lookup for a config value. 30 | -- Return default value otherwise. 31 | -- 32 | lookupConfigDefault :: (MonadIO (m b v), MonadSnaplet m, Configured a) 33 | => Name -- ^ Key 34 | -> a -- ^ default value 35 | -> m b v a 36 | lookupConfigDefault name def = liftM (fromMaybe def) (lookupConfig name) 37 | -------------------------------------------------------------------------------- /src/Text/Digestive/FormExt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- 4 | -- Extension to Text.Digestive.Form. 5 | -- Basically more utils. 6 | -- 7 | 8 | module Text.Digestive.FormExt where 9 | 10 | import Data.Maybe (isJust) 11 | import Data.Text (Text) 12 | import qualified Data.Text as T 13 | import Text.Digestive 14 | 15 | 16 | ---------------------------------------------------- Validator 17 | 18 | -- | MAYBE: more accurate email addr. validator. 19 | -- 20 | emailValidator :: T.Text -> Bool 21 | emailValidator = isJust . T.find (== '@') 22 | 23 | 24 | -- | Mandatroy field validator. 25 | -- 26 | requiredValidator :: T.Text -> Bool 27 | requiredValidator = not . T.null . T.strip 28 | 29 | 30 | maxListValidator :: Int -- ^ Max 31 | -> (Text -> [Text]) -- ^ Convert to list 32 | -> Text -- ^ Input text 33 | -> Bool 34 | maxListValidator n f = (<= n) . length . f 35 | 36 | 37 | ---------------------------------------------------- Validate Action 38 | 39 | 40 | -- | Check for required field with error message @msg@ 41 | -- 42 | checkRequired :: Monad m => Text -> Form Text m Text -> Form Text m Text 43 | checkRequired msg = check msg requiredValidator 44 | 45 | 46 | -- | Check for required field with error message @msg@ 47 | -- 48 | checkValidEmail :: Monad m => Form Text m Text -> Form Text m Text 49 | checkValidEmail = check "Please input valid email address." emailValidator 50 | 51 | 52 | -- | Check for min length reqirued. 53 | -- 54 | checkMinLength :: Monad m => Int -> Form Text m Text -> Form Text m Text 55 | checkMinLength l = checkMinLengthWith l "Content" 56 | 57 | checkMinLengthWith :: Monad m 58 | => Int 59 | -> Text 60 | -> Form Text m Text -> Form Text m Text 61 | checkMinLengthWith l msg = check (msg `T.append` " is too simple. min length " `T.append` intToText) minLength 62 | where minLength = (>= l) . T.length 63 | intToText = T.pack (show l) 64 | 65 | 66 | -- | Check for max length reqirued. 67 | -- 68 | checkMaxLength :: Monad m => Int -> Form Text m Text -> Form Text m Text 69 | checkMaxLength l = checkMaxLengthWith l "Content" 70 | 71 | checkMaxLengthWith :: Monad m 72 | => Int 73 | -> Text 74 | -> Form Text m Text -> Form Text m Text 75 | checkMaxLengthWith l msg = check (msg `T.append` " exceeds max length " `T.append` intToText) maxLength 76 | where maxLength = (<= l) . T.length 77 | intToText = T.pack (show l) 78 | -------------------------------------------------------------------------------- /src/Text/Digestive/HeistExt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Text.Digestive.HeistExt where 5 | 6 | import Data.Text (Text) 7 | import Text.Digestive 8 | import qualified Heist.Interpreted as I 9 | import qualified Text.XmlHtml as X 10 | 11 | 12 | dfChildErrorListRef :: Monad m => View Text -> I.Splice m 13 | dfChildErrorListRef view = 14 | return $ errorList (viewErrors view) 15 | where errorList :: [(Path, Text)] -> [X.Node] 16 | errorList [] = [] 17 | errorList errs = [X.Element "ul" [] $ map makeError errs] 18 | makeError (p:_, e) = X.Element "li" [("data-error", p)] [X.TextNode e] 19 | -------------------------------------------------------------------------------- /src/Views/Feed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Views.Feed where 5 | 6 | import Blaze.ByteString.Builder (Builder) 7 | import Text.XmlHtml 8 | 9 | import Models.Feed 10 | import Views.MarkdownSplices (markdownToHtmlText) 11 | import Views.Utils (formatUTCTime) 12 | 13 | renderFeed :: Feed -> Builder 14 | renderFeed f = 15 | render $ XmlDocument UTF8 Nothing [root] 16 | where 17 | namespace = "http://www.w3.org/2005/Atom" 18 | root = Element "feed" [("xmlns", namespace)] 19 | $ Element "title" [] [TextNode $ feedTitle f] 20 | : Element "link" [("href", feedLinkSelf f), ("rel", "self")] [] 21 | : Element "link" [("href", feedLinkHome f)] [] 22 | : Element "updated" [] [TextNode $ formatUTCTime $ feedUpdated f] 23 | : map renderFeedEntry (feedEntries f) 24 | 25 | renderFeedEntry :: FeedEntry -> Node 26 | renderFeedEntry e = 27 | Element "entry" [] 28 | [ Element "title" [] [TextNode $ feedEntryTitle e] 29 | , Element "link" [("href", feedEntryLink e)] [] 30 | , Element "id" [] [TextNode $ feedEntryId e] 31 | , Element "author" [] 32 | [ Element "name" [] [TextNode $ feedEntryAuthorName e] 33 | , Element "uri" [] [TextNode $ feedEntryAuthorUri e] 34 | ] 35 | , Element "published" [] [TextNode $ formatUTCTime $ feedEntryPublished e] 36 | , Element "content" [("type","html")] [TextNode $ markdownToHtmlText $ feedEntryContent e] 37 | ] 38 | -------------------------------------------------------------------------------- /src/Views/MarkdownSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | transform any markdown content to html 5 | -- 6 | -- 7 | module Views.MarkdownSplices 8 | ( markdownToHtmlSplice 9 | , markdownToHtmlBS 10 | , markdownToHtmlText 11 | ) where 12 | 13 | import qualified Codec.Binary.UTF8.String as UTF8 14 | import Control.Monad.Trans 15 | import qualified Data.ByteString.Char8 as BS 16 | import qualified Data.Set as Set 17 | import qualified Data.Text as T 18 | import qualified Heist.Interpreted as I 19 | import Models.Utils 20 | import Text.HTML.SanitizeXSS 21 | import Text.Pandoc 22 | import Text.Pandoc.Shared (tabFilter) 23 | import qualified Text.XmlHtml as X 24 | 25 | ---------------------------------------------------------------------- 26 | 27 | markdownToHtmlSplice :: MonadIO m => T.Text -> I.Splice m 28 | markdownToHtmlSplice markup = 29 | either throwError toDoc $ X.parseHTML "" $ markdownToHtmlBS markup 30 | where throwError e = return [X.TextNode $ T.pack ("Error parsing markdown output: " ++ e)] 31 | --MAYBE:ERROR STYLE 32 | toDoc = return . X.docContent 33 | 34 | xss :: BS.ByteString -> T.Text 35 | xss = sanitizeBalance . bsToText 36 | 37 | -- | Convert tabs to spaces and filter out DOS line endings. 38 | tabFilter4 :: String -> String 39 | tabFilter4 = tabFilter 4 40 | 41 | -- | Convert markdown doc to @ByteString@ 42 | -- 43 | markdownToHtmlBS :: T.Text -> BS.ByteString 44 | markdownToHtmlBS = textToBS . markdownToHtmlText 45 | 46 | -- | Convert markdown doc to @Text@ 47 | -- 48 | markdownToHtmlText :: T.Text -> T.Text 49 | markdownToHtmlText = xss . BS.pack . writeDoc . readDoc . tabFilter4 . T.unpack 50 | 51 | readDoc :: String -> Pandoc 52 | readDoc = readMarkdown parserOptions 53 | 54 | parserOptions :: ReaderOptions 55 | parserOptions = let d = def 56 | ext = Set.union (readerExtensions d) hcnMarkdownExtensions 57 | in 58 | d { readerExtensions = ext } 59 | 60 | writeDoc :: Pandoc -> String 61 | writeDoc = UTF8.encodeString . writeHtmlString writerOptions 62 | 63 | writerOptions :: WriterOptions 64 | writerOptions = def { writerHighlight = True 65 | , writerHTMLMathMethod = googleApiMathMethod 66 | } 67 | 68 | googleApiMathMethod :: HTMLMathMethod 69 | googleApiMathMethod = WebTeX "http://chart.apis.google.com/chart?cht=tx&chl=" 70 | 71 | hcnMarkdownExtensions :: Set.Set Extension 72 | hcnMarkdownExtensions = Set.fromList 73 | [ Ext_pipe_tables 74 | , Ext_raw_html 75 | , Ext_tex_math_single_backslash 76 | , Ext_fenced_code_blocks 77 | , Ext_fenced_code_attributes 78 | , Ext_auto_identifiers 79 | , Ext_ascii_identifiers 80 | , Ext_backtick_code_blocks 81 | , Ext_autolink_bare_uris 82 | , Ext_intraword_underscores 83 | , Ext_strikeout 84 | , Ext_hard_line_breaks 85 | , Ext_lists_without_preceding_blankline 86 | , Ext_literate_haskell 87 | ] -------------------------------------------------------------------------------- /src/Views/PaginationSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Views.PaginationSplices where 4 | 5 | import qualified Data.ByteString as BS 6 | import qualified Data.Text as T 7 | import qualified Heist.Interpreted as I 8 | import Snap 9 | import Snap.Snaplet.Environments 10 | import qualified Text.XmlHtml as X 11 | 12 | import Application 13 | import Models.Utils 14 | 15 | -- TODO: refactoring 16 | -- 0. find total number 17 | -- 1. Maybe PageNum 18 | -- 2. search topic per PageNum (for skip) and PageSize 19 | -- 3. generate pagination splice 20 | 21 | -- | Select items for particular page base on Page Size, Current Page 22 | -- 23 | paginationHandler :: (Eq b, Integral a, Show a) 24 | => a -- ^ Current Page 25 | -> [b] -- ^ Total items 26 | -> AppHandler (Int, [b], I.Splice AppHandler) -- ^ items for current page and page splice 27 | paginationHandler cp xs = do 28 | pageSize <- getPageSize 29 | req <- getRequest 30 | let uri = requestURL (rqURI req) 31 | -- liftIO $ print $ 32 | let total = length xs 33 | sDouble = fromIntegral pageSize 34 | pageCount' = ceiling $ fromIntegral total / sDouble 35 | cp' = fixCurrentPage cp pageCount' 36 | pageNumberList = [1..pageCount'] 37 | pageItems = sliceForPage cp' pageSize xs 38 | pageSplice = return [paginationNode cp' pageNumberList (urlGen uri)] 39 | startIndex = 1 + pageSize * fromIntegral (cp' - 1) 40 | return (startIndex, pageItems, pageSplice) 41 | 42 | getPageSize :: AppHandler Int 43 | getPageSize = lookupConfigDefault "pagesize" 20 44 | 45 | -- | Request URL could be "/", "/tags/xxx", "/?pagenum=2", etc. 46 | -- Fetch the URI regardless of parameter via '?'. 47 | -- 48 | requestURL :: BS.ByteString -> T.Text 49 | requestURL = T.takeWhile (/= '?') . bsToText 50 | 51 | ---------------------------------------------------------------------------- 52 | 53 | -- | Generate HTML nodes for topic pagination. 54 | -- Elements created here because of not sure how to set up "active" class. 55 | -- 56 | paginationNode :: (Show a, Integral a) 57 | => a -- ^ Current Page 58 | -> [a] -- ^ Page Number List 59 | -> (T.Text -> T.Text) -- ^ pagination url generator 60 | -> X.Node -- ^ HTML Nodes for page numbers 61 | paginationNode _ [] _ = X.Comment "insufficient data for pagination" 62 | paginationNode i xs gen = 63 | let cp = sToText i 64 | doNode = X.Element "ul" [("class", "pagination pagination-lg")] lis 65 | lis = map (f . sToText) xs 66 | f n 67 | | cp == n = X.Element "li" [("class","active")] [a n] 68 | | otherwise = X.Element "li" [] [a n] 69 | a n 70 | | cp == n = X.Element "a" [] [X.TextNode n] 71 | | otherwise = X.Element "a" [("href", gen n)] [X.TextNode n] 72 | in doNode 73 | 74 | 75 | -- | Create URL generator base on given root url 76 | -- 77 | urlGen :: T.Text -> T.Text -> T.Text 78 | urlGen t = T.append (t `T.append` topicHref) 79 | 80 | topicHref :: T.Text 81 | topicHref = "?p=" 82 | 83 | 84 | --------------------------------------------------------------- 85 | 86 | -- | slice for page. 87 | -- Fetching items from whole collection for particular page. 88 | sliceForPage :: (Eq b, Integral a) 89 | => a -- ^ current page 90 | -> Int -- ^ page size 91 | -> [b] -- ^ all items 92 | -> [b] -- ^ selected items for current page. 93 | sliceForPage _ _ [] = [] 94 | sliceForPage 0 s xs = sliceForPage 1 s xs 95 | sliceForPage cp size xs = take size $ drop (drops cp) xs 96 | where drops = (* size) . flip (-) 1 . fromIntegral 97 | 98 | 99 | --------------------------------------------------------------- 100 | 101 | 102 | -- | Fixing invalide page number. 103 | -- e.g. total page number is 2 but given current page 3, show the last page (2 here) instead. 104 | -- 105 | fixCurrentPage :: Integral a 106 | => a -- ^ Current Page 107 | -> a -- ^ How many page numbers in total 108 | -> a -- ^ A valid page number 109 | fixCurrentPage cp total = if cp > total then total else cp 110 | -------------------------------------------------------------------------------- /src/Views/ReplyForm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Views.ReplyForm where 4 | 5 | import Data.Text (Text) 6 | import qualified Data.Text as T 7 | import Snap 8 | import Text.Digestive 9 | import Text.Digestive.FormExt 10 | import Text.Digestive.Snap 11 | 12 | ------------------------------------------------------------ 13 | 14 | data ReplyVo = ReplyVo 15 | { replyToTopicId :: T.Text 16 | , replyToReplyId :: T.Text -- Maybe Empty 17 | , replyContent :: T.Text 18 | } deriving (Show) 19 | 20 | ------------------------------------------------------------ 21 | 22 | 23 | runReplyForm :: MonadSnap m => m (View Text, Maybe ReplyVo) 24 | runReplyForm = runForm "reply-to-topic-form" replyForm 25 | 26 | 27 | replyForm :: Monad m => Form Text m ReplyVo 28 | replyForm = ReplyVo 29 | <$> "replyToTopicId" .: checkRequired "replyToTopicId is required" (text Nothing) 30 | <*> "replyToReplyId" .: text Nothing 31 | <*> "content" .: contentValidation (text Nothing) 32 | 33 | ------------------------------------------------------------ 34 | 35 | runReplyToRelpyForm :: MonadSnap m => m (View Text, Maybe ReplyVo) 36 | runReplyToRelpyForm = runForm "reply-to-reply-form" replyToRelpyForm 37 | 38 | -- | 39 | -- 40 | replyToRelpyForm :: Monad m => Form Text m ReplyVo 41 | replyToRelpyForm = ReplyVo 42 | <$> "replyToTopicId" .: checkRequired "replyToReplyTopicId is required" (text Nothing) 43 | <*> "replyToReplyId" .: checkRequired "replyToReplyReplyId is required" (text Nothing) 44 | <*> "replyContent" .: replyOfReplyContentMaxLength (contentValidation (text Nothing)) 45 | 46 | replyOfReplyContentMaxLength :: Monad m => Form Text m Text -> Form Text m Text 47 | replyOfReplyContentMaxLength = checkMaxLength 160 48 | 49 | 50 | ------------------------------------------------------------ 51 | 52 | contentValidation :: Monad m => Form Text m Text -> Form Text m Text 53 | contentValidation = checkMinLength 6 . checkRequired "Reply content can not be empty." 54 | -------------------------------------------------------------------------------- /src/Views/ReplySplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Views.ReplySplices where 5 | 6 | import Control.Arrow (second) 7 | import Control.Monad (liftM) 8 | import Control.Monad.Trans 9 | import Data.Function (on) 10 | import Data.List 11 | import qualified Data.Map as MP 12 | import Data.Monoid (mconcat) 13 | import qualified Data.Text as T 14 | import Data.Time 15 | import Heist 16 | import qualified Heist.Interpreted as I 17 | 18 | import Application 19 | import Models.Reply 20 | import Models.User 21 | import Models.Utils 22 | import Views.MarkdownSplices 23 | import Views.UserSplices 24 | import Views.Utils 25 | 26 | -- | A Reply and its own replies. 27 | -- 28 | type ReplyWithReply = (Reply, [Reply]) 29 | 30 | 31 | ------------------------------------------------------------------------------ 32 | 33 | -- | Reply with all children 34 | -- 35 | allReplyPerTopicSplice :: [Reply] -> I.Splice AppHandler 36 | allReplyPerTopicSplice xs = I.mapSplices replySpliceWithChildren (splitReplies xs) 37 | 38 | -- | Display content of a reply as markdown. 39 | -- Display content of a comment (reply of reply) as plain content. 40 | -- 41 | replySpliceWithChildren :: ReplyWithReply -> I.Splice AppHandler 42 | replySpliceWithChildren (r, rs) = do 43 | now <- liftIO getCurrentTime 44 | user <- findReplyAuthor r 45 | I.runChildrenWith $ foldSplices $ 46 | [ ("replyEditable", hasEditPermissionSplice user) 47 | , ("replyToReply", I.mapSplices replyToReplySplice rs) 48 | , ("replyContentMD", markdownToHtmlSplice $ _replyContent r) 49 | ] 50 | ++ map (second I.textSplice) (replySpliceImpl r user now) 51 | 52 | 53 | ------------------------------------------------------------------------------ 54 | 55 | 56 | -- | Just a Reply without any children 57 | -- 58 | replyToReplySplice :: Reply -> I.Splice AppHandler 59 | replyToReplySplice r = do 60 | now <- liftIO getCurrentTime 61 | user <- findReplyAuthor r 62 | I.runChildrenWith $ foldSplices $ 63 | [ ("replyEditable", hasEditPermissionSplice user) 64 | , ("replyContentMD", markdownToHtmlSplice $ _replyContent r) 65 | ] 66 | ++ map (second I.textSplice) (replySpliceImpl r user now) 67 | 68 | 69 | replySpliceImpl :: Reply 70 | -> User -- ^ UserName 71 | -> UTCTime 72 | -> [(T.Text, T.Text)] 73 | replySpliceImpl r user now = 74 | [ ("replyAuthor", _userDisplayName user) 75 | , ("replyAuthorId", sToText $ _replyAuthor r) 76 | , ("replyId", getReplyId r) 77 | , ("replyToTopicId", sToText $ _replyToTopicId r) 78 | , ("replyToReplyId", objectIdToText $ _replyToReplyId r) 79 | , ("replyCreateAt", relativeUTCTime (_replyCreateAt r) now) 80 | ] 81 | -- , ("replyContent", _replyContent r) ] 82 | 83 | 84 | ------------------------------------------------------------------------------ 85 | 86 | -- | Separate Reply by whether it is a reply or a reply of reply, then zip together. 87 | -- FIXME: 88 | -- 1. a little complex 89 | -- 2. unit test 90 | -- 91 | splitReplies :: [Reply] -> [ReplyWithReply] 92 | splitReplies rs = 93 | map (g $ toMap $ grouyByToReplyId $ sortByToReplyId $ nonFirstLevelReply rs) 94 | (firstLevelReply rs) 95 | where sortByToReplyId = sortBy (compare `on` toReplyId) 96 | grouyByToReplyId = groupBy ((==) `on` _replyToReplyId) 97 | toMap = MP.fromList . map (\xs -> (toReplyId (head xs) , xs)) 98 | toReplyId = objectIdToText . _replyToReplyId 99 | g m r = case MP.lookup (getReplyId r) m of 100 | Nothing -> (r, []) 101 | Just xs -> (r, xs) 102 | 103 | 104 | 105 | -- | @Splice@ is type synonium as @Splice m = HeistT m Template@ 106 | -- 107 | findReplyAuthor :: Reply -> HeistT AppHandler AppHandler User 108 | findReplyAuthor reply = lift (findUser' reply) 109 | where findUser' = findOneUser . _replyAuthor 110 | 111 | findReplyAuthorName :: Reply 112 | -> HeistT AppHandler AppHandler T.Text 113 | findReplyAuthorName reply = liftM _userDisplayName (findReplyAuthor reply) 114 | -------------------------------------------------------------------------------- /src/Views/SharedSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExtendedDefaultRules #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Views.SharedSplices where 6 | 7 | import Application 8 | import qualified Data.ByteString as BS 9 | import qualified Data.Text as T 10 | import qualified Heist.Interpreted as I 11 | import Models.User 12 | import Models.Utils (bsToText) 13 | import Snap 14 | import Snap.Snaplet.Heist 15 | 16 | ---------------------------------------------------------------------------- 17 | 18 | sharedSplices :: [(T.Text, SnapletISplice App)] 19 | sharedSplices = [ ("currentUser", currentUserSplice) 20 | , ("isCurrentUserAdmin", isCurrentUserAdminSplice) 21 | , ("goto", currentURISplice) 22 | ] 23 | 24 | ---------------------------------------------------------------------------- 25 | 26 | nextPageParam :: BS.ByteString 27 | nextPageParam = "goto" 28 | 29 | genNextPageParam :: AppHandler BS.ByteString 30 | genNextPageParam = liftM (gen . rqURI) getRequest 31 | where gen uri 32 | | uri == "/" = "" 33 | | otherwise = foldr1 BS.append ["?", nextPageParam, "=", uri] 34 | 35 | -- | current URI 36 | currentURISplice :: SnapletISplice App 37 | currentURISplice = lift currentUri >>= I.textSplice 38 | where currentUri = liftM bsToText genNextPageParam 39 | 40 | -- | Current @User@ splice. Diff with Snaplet-Auth.loggedInUser which return @AuthUser@ 41 | -- 42 | currentUserSplice :: SnapletISplice App 43 | currentUserSplice = lift findCurrentUser 44 | >>= I.textSplice . _userDisplayName 45 | 46 | -- | Whether current user has admin role. 47 | -- 48 | isCurrentUserAdminSplice :: SnapletISplice App 49 | isCurrentUserAdminSplice = do 50 | tf <- lift isCurrentUserAdmin 51 | if tf then I.runChildren else return [] 52 | -------------------------------------------------------------------------------- /src/Views/TagSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Views.TagSplices where 5 | 6 | import Application 7 | import Control.Monad.Trans 8 | import Data.Bson (ObjectId) 9 | import Data.Maybe (fromMaybe) 10 | import qualified Data.Text as T 11 | import Heist 12 | import qualified Heist.Interpreted as I 13 | import Models.Tag 14 | import Models.Utils 15 | 16 | ------------------------------------------------------------------------------ 17 | 18 | -- | Splice of listing multiple tags 19 | -- 20 | topicTagSplice :: Maybe [ObjectId] -> I.Splice AppHandler 21 | topicTagSplice ids = 22 | lift (findSomeTags $ fromMaybe [] ids) 23 | -- >>= mapSplices tagSplice 24 | >>= tagsSplice 25 | 26 | tagSplice :: Tag -> I.Splice AppHandler 27 | tagSplice = I.runChildrenWithText . tagSpliceImpl 28 | 29 | 30 | tagSpliceImpl :: Tag -> Splices T.Text 31 | tagSpliceImpl (Tag tid name _) = do 32 | "tagId" ## objectIdToText tid 33 | "tagName" ## name 34 | 35 | tagsSplice :: [Tag] -> I.Splice AppHandler 36 | tagsSplice = I.mapSplices tagSplice 37 | -------------------------------------------------------------------------------- /src/Views/TopicForm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Views.TopicForm where 4 | 5 | import Control.Applicative ((<$>), (<*>)) 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | import Text.Digestive 9 | import Text.Digestive.FormExt 10 | 11 | import Models.Tag 12 | import Models.Topic 13 | import Models.Utils 14 | 15 | 16 | -- | VO is created because it is not quite easy to use single 17 | -- model @Models.Topic.Topic@. 18 | -- 19 | data TopicVo = TopicVo 20 | { title :: T.Text 21 | , content :: T.Text 22 | , topicId :: T.Text 23 | , topicTags :: T.Text 24 | } deriving (Show) 25 | 26 | 27 | maxTitleLength, minTitleLength, minContentLength, maxTagsCount :: Int 28 | maxTitleLength = 100 29 | minTitleLength = 5 30 | minContentLength = 10 31 | maxTagsCount = 8 32 | 33 | 34 | -- | FIXME: Need a better design to get message from i18n snaplet. 35 | -- 36 | topicForm :: Monad m => Form Text m TopicVo 37 | topicForm = TopicVo 38 | <$> "title" .: titleValidation (text Nothing) 39 | <*> "content" .: contentValidation (text Nothing) 40 | <*> "tid" .: text Nothing 41 | <*> "tags" .: tagsValidation (text Nothing) 42 | 43 | -- | Render a form base on exists @Topic@ for editing. 44 | -- 45 | -- 46 | topicEditForm :: Monad m => Topic -> [Tag] -> Form Text m TopicVo 47 | topicEditForm t tags = TopicVo 48 | <$> "title" .: titleValidation (text $ Just $ _title t) 49 | <*> "content" .: contentValidation (text $ Just $ _content t) 50 | <*> "tid" .: checkRequired "Fatal error happened.(tid is required)" (text $ fmap sToText (_topicId t)) 51 | <*> "tags" .: tagsValidation (tagsToText tags) 52 | 53 | -- | combinate tag names to display. 54 | -- 55 | tagsToText :: Monad m => [Tag] -> Form Text m Text 56 | tagsToText = text . Just . T.intercalate " " . map _tagName 57 | 58 | 59 | -- | Topic Title Validation. (Required + minlength 5) 60 | -- 61 | titleValidation :: Monad m => Form Text m Text -> Form Text m Text 62 | titleValidation = checkMaxLengthWith maxTitleLength "Title" 63 | . checkMinLengthWith minTitleLength "Title" 64 | . checkRequired "title is required" 65 | 66 | 67 | -- | Topic Content Validation. (Required + minlength 10) 68 | -- 69 | contentValidation :: Monad m => Form Text m Text -> Form Text m Text 70 | contentValidation = checkMinLength minContentLength . checkRequired "content is required" 71 | 72 | 73 | -- | Tags Validation. (no more than 8 tags) 74 | -- 75 | tagsValidation :: Monad m => Form Text m Text -> Form Text m Text 76 | tagsValidation = check "No more than 8 Tags" (maxListValidator maxTagsCount splitOnSpaceOrComma) 77 | 78 | -------------------------------------------------------------------------------- /src/Views/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Views.Types where 4 | 5 | import Application 6 | import Heist 7 | import qualified Heist.Interpreted as I 8 | import Models.Exception 9 | 10 | -- | This class is born because when do MonadIO.try with models functions, 11 | -- its return type is `Either exception data`. Hence make a generic render. 12 | -- See also the helper @eitherToSplices@. 13 | -- 14 | class SpliceRenderable a where 15 | toSplice :: a -> I.Splice AppHandler 16 | 17 | -------------------------------------------------------------- 18 | 19 | -- | FIXME: What if at some exception case, should both should content and error?? 20 | -- 21 | eitherToSplices :: SpliceRenderable a => Either UserException a -> Splices (I.Splice AppHandler) 22 | eitherToSplices (Left l) = do 23 | "ifFound" ## return [] 24 | "ifNotFound" ## toSplice l 25 | 26 | eitherToSplices (Right r) = do 27 | "ifFound" ## toSplice r 28 | "ifNotFound" ## return [] 29 | 30 | --eitherToSplices :: SpliceRenderable a => Either UserException a -> [(T.Text, I.Splice AppHandler)] 31 | --eitherToSplices (Left l) = [ ("ifFound" , return []) 32 | -- , ("ifNotFound", toSplice l) ] 33 | -- 34 | --eitherToSplices (Right r) = [ ("ifFound" , toSplice r) 35 | -- , ("ifNotFound", return []) ] 36 | 37 | 38 | -------------------------------------------------------------- 39 | 40 | instance SpliceRenderable UserException where 41 | toSplice a = I.runChildrenWithText ("exceptionValue" ## showUE a) 42 | -------------------------------------------------------------------------------- /src/Views/UserForm.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Views.UserForm where 3 | 4 | import Control.Applicative ((<$>), (<*>)) 5 | import Data.Maybe (fromMaybe) 6 | import Data.Text (Text) 7 | import Text.Digestive 8 | import Text.Digestive.FormExt 9 | 10 | import Models.User 11 | import Models.Utils 12 | 13 | -- | 14 | data UserVo = UserVo 15 | { userVoId :: Text 16 | , userEmail :: Text 17 | , userDisplayName :: Text 18 | , userSite :: Text 19 | } deriving (Show) 20 | 21 | data LoginFormUser = LoginFormUser 22 | { _loginName :: Email 23 | , _password :: Text 24 | , _nextPageUri :: Text 25 | } deriving (Show) 26 | 27 | ------------------------------------------------------------------ 28 | -- 29 | signinForm :: Monad m 30 | => Maybe Text 31 | -> Form Text m LoginFormUser 32 | signinForm nextPageUri = LoginFormUser 33 | <$> "loginName" .: checkRequired loginNameRequired (text Nothing) 34 | <*> "password" .: checkRequired passwordRequired (text Nothing) 35 | <*> "nextPageUri" .: text nextPageUri 36 | 37 | signupForm :: Monad m => Form Text m LoginUser 38 | signupForm = check "Two Input password must be same" samePasswordValidator $ 39 | LoginUser 40 | <$> "loginName" .: (checkValidEmail . checkRequired loginNameRequired) (text Nothing) 41 | <*> "password" .: passwordValidator (text Nothing) 42 | <*> "repeatPassword" .: checkRequired "Please input the password again" (text Nothing) 43 | 44 | samePasswordValidator :: LoginUser -> Bool 45 | samePasswordValidator x = password x == repeatPassword x 46 | 47 | passwordValidator :: Monad m => Form Text m Text -> Form Text m Text 48 | passwordValidator = checkMaxLengthWith 20 "Password" 49 | . checkMinLengthWith 8 "Password" 50 | . checkRequired passwordRequired 51 | 52 | resetPasswordForm :: Monad m => Form Text m LoginUser 53 | resetPasswordForm = signupForm 54 | 55 | loginNameRequired, passwordRequired :: Text 56 | loginNameRequired = "Login Name is required" 57 | passwordRequired = "Password is required" 58 | 59 | 60 | ------------------------------------------------------------------ 61 | -- 62 | 63 | -- | Prepare a form for display from a exists @User@. 64 | -- 65 | userDetailForm :: Monad m => User -> Form Text m UserVo 66 | userDetailForm u = UserVo 67 | <$> "userVoId" .: text (Just $ objectIdToText $ getUserId' u) 68 | <*> "userEmail" .: text (Just $ _userEmail u) 69 | <*> "userDisplayName" .: text (Just $ _userDisplayName u) 70 | <*> "userSite" .: text (Just $ fromMaybe "" $ _userSite u) 71 | 72 | -- | 73 | -- 74 | userForm :: Monad m => Form Text m UserVo 75 | userForm = UserVo 76 | <$> "userVoId" .: text Nothing 77 | <*> "userEmail" .: text Nothing 78 | <*> "userDisplayName" .: text Nothing 79 | <*> "userSite" .: text Nothing 80 | 81 | ------------------------------------------------------------------ 82 | -------------------------------------------------------------------------------- /src/Views/UserSplices.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExtendedDefaultRules #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Views.UserSplices where 5 | 6 | import Control.Arrow (second) 7 | import Control.Monad.Trans 8 | import Data.Maybe (fromMaybe) 9 | import qualified Data.Text as T 10 | import Data.Time 11 | import Heist 12 | import qualified Heist.Interpreted as I 13 | import Snap.Snaplet.Auth 14 | 15 | import Application 16 | import Models.Exception 17 | import Models.User 18 | import Models.Utils 19 | import Views.Types 20 | import Views.Utils 21 | 22 | ------------------------------------------------------------------------------ 23 | 24 | instance SpliceRenderable User where 25 | toSplice = renderUser 26 | 27 | ------------------------------------------------------------------------------ 28 | 29 | -- | Splices used at user Detail page. 30 | -- Display either a user or error msg. 31 | -- 32 | 33 | userDetailSplices :: Either UserException User -> Splices (I.Splice AppHandler) 34 | userDetailSplices = eitherToSplices 35 | 36 | 37 | ------------------------------------------------------------------------------ 38 | 39 | -- | Single user to Splice. 40 | -- 41 | renderUser :: User -> I.Splice AppHandler 42 | renderUser user = I.runChildrenWith $ foldSplices $ 43 | [ ("userEditable", hasEditPermissionSplice user) 44 | --, ("userLastLoginAt", userLastLoginAtSplice $ _authUser user) 45 | , ("isAuthUser", isAuthUserRetrieved $ _authUser user) 46 | ] 47 | ++ 48 | map (second I.textSplice) 49 | [ ("userLogin", maybe "" userLogin $ _authUser user) 50 | , ("userEmail", _userEmail user) 51 | , ("userDisplayName", _userDisplayName user) 52 | , ("userSite", fromMaybe "" $ _userSite user) 53 | , ("userId", maybe "error-no-user-id-found" sToText $ getUserId' user) 54 | ] 55 | 56 | formatUTCTimeMaybe :: Maybe UTCTime -> T.Text 57 | formatUTCTimeMaybe Nothing = "" 58 | formatUTCTimeMaybe (Just x) = formatUTCTime x 59 | 60 | 61 | isAuthUserRetrieved :: Maybe AuthUser 62 | -> I.Splice AppHandler 63 | isAuthUserRetrieved Nothing = return [] 64 | isAuthUserRetrieved (Just authusr) = 65 | I.runChildrenWithText $ do 66 | "lastLoginTime" ## formatUTCTimeMaybe $ userLastLoginAt authusr 67 | "createdAt" ## formatUTCTimeMaybe $ userCreatedAt authusr 68 | 69 | ---------------------------------------------------------------------------- 70 | 71 | -- | Has Edit premission when either current user is Admin or Author. 72 | -- 73 | hasEditPermissionSplice :: User -- ^ Author of some. 74 | -> I.Splice AppHandler 75 | hasEditPermissionSplice author = do 76 | has <- lift $ hasUpdatePermission author 77 | if has then I.runChildren else return [] 78 | 79 | ---------------------------------------------------------------------------- 80 | -------------------------------------------------------------------------------- /static/bootstrap/alerts.less: -------------------------------------------------------------------------------- 1 | // 2 | // Alerts 3 | // -------------------------------------------------- 4 | 5 | 6 | // Base styles 7 | // ------------------------- 8 | 9 | .alert { 10 | padding: @alert-padding; 11 | margin-bottom: @line-height-computed; 12 | border: 1px solid transparent; 13 | border-radius: @alert-border-radius; 14 | 15 | // Headings for larger alerts 16 | h4 { 17 | margin-top: 0; 18 | // Specified for the h4 to prevent conflicts of changing @headings-color 19 | color: inherit; 20 | } 21 | // Provide class for links that match alerts 22 | .alert-link { 23 | font-weight: @alert-link-font-weight; 24 | } 25 | 26 | // Improve alignment and spacing of inner content 27 | > p, 28 | > ul { 29 | margin-bottom: 0; 30 | } 31 | > p + p { 32 | margin-top: 5px; 33 | } 34 | } 35 | 36 | // Dismissable alerts 37 | // 38 | // Expand the right padding and account for the close button's positioning. 39 | 40 | .alert-dismissable { 41 | padding-right: (@alert-padding + 20); 42 | 43 | // Adjust close link position 44 | .close { 45 | position: relative; 46 | top: -2px; 47 | right: -21px; 48 | color: inherit; 49 | } 50 | } 51 | 52 | // Alternate styles 53 | // 54 | // Generate contextual modifier classes for colorizing the alert. 55 | 56 | .alert-success { 57 | .alert-variant(@alert-success-bg; @alert-success-border; @alert-success-text); 58 | } 59 | .alert-info { 60 | .alert-variant(@alert-info-bg; @alert-info-border; @alert-info-text); 61 | } 62 | .alert-warning { 63 | .alert-variant(@alert-warning-bg; @alert-warning-border; @alert-warning-text); 64 | } 65 | .alert-danger { 66 | .alert-variant(@alert-danger-bg; @alert-danger-border; @alert-danger-text); 67 | } 68 | -------------------------------------------------------------------------------- /static/bootstrap/badges.less: -------------------------------------------------------------------------------- 1 | // 2 | // Badges 3 | // -------------------------------------------------- 4 | 5 | 6 | // Base class 7 | .badge { 8 | display: inline-block; 9 | min-width: 10px; 10 | padding: 3px 7px; 11 | font-size: @font-size-small; 12 | font-weight: @badge-font-weight; 13 | color: @badge-color; 14 | line-height: @badge-line-height; 15 | vertical-align: baseline; 16 | white-space: nowrap; 17 | text-align: center; 18 | background-color: @badge-bg; 19 | border-radius: @badge-border-radius; 20 | 21 | // Empty badges collapse automatically (not available in IE8) 22 | &:empty { 23 | display: none; 24 | } 25 | 26 | // Quick fix for badges in buttons 27 | .btn & { 28 | position: relative; 29 | top: -1px; 30 | } 31 | .btn-xs & { 32 | top: 0; 33 | padding: 1px 5px; 34 | } 35 | 36 | // Hover state, but only for links 37 | a& { 38 | &:hover, 39 | &:focus { 40 | color: @badge-link-hover-color; 41 | text-decoration: none; 42 | cursor: pointer; 43 | } 44 | } 45 | 46 | // Account for badges in navs 47 | a.list-group-item.active > &, 48 | .nav-pills > .active > a > & { 49 | color: @badge-active-color; 50 | background-color: @badge-active-bg; 51 | } 52 | .nav-pills > li > a > & { 53 | margin-left: 3px; 54 | } 55 | } 56 | -------------------------------------------------------------------------------- /static/bootstrap/bootstrap.less: -------------------------------------------------------------------------------- 1 | // Core variables and mixins 2 | @import "variables.less"; 3 | @import "mixins.less"; 4 | 5 | // Reset and dependencies 6 | @import "normalize.less"; 7 | //@import "print.less"; 8 | @import "glyphicons.less"; 9 | 10 | // Core CSS 11 | @import "scaffolding.less"; 12 | @import "type.less"; 13 | @import "code.less"; 14 | @import "grid.less"; 15 | //@import "tables.less"; 16 | @import "forms.less"; 17 | @import "buttons.less"; 18 | 19 | // Components 20 | @import "component-animations.less"; 21 | //@import "dropdowns.less"; 22 | @import "button-groups.less"; 23 | @import "input-groups.less"; 24 | @import "navs.less"; 25 | @import "navbar.less"; 26 | //@import "breadcrumbs.less"; 27 | @import "pagination.less"; 28 | //@import "pager.less"; 29 | @import "labels.less"; 30 | @import "badges.less"; 31 | @import "jumbotron.less"; 32 | @import "thumbnails.less"; 33 | @import "alerts.less"; 34 | //@import "progress-bars.less"; 35 | //@import "media.less"; 36 | @import "list-group.less"; 37 | @import "panels.less"; 38 | @import "responsive-embed.less"; 39 | //@import "wells.less"; 40 | //@import "close.less"; 41 | 42 | // Components w/ JavaScript 43 | //@import "modals.less"; 44 | //@import "tooltip.less"; 45 | //@import "popovers.less"; 46 | //@import "carousel.less"; 47 | 48 | // Utility classes 49 | @import "utilities.less"; 50 | @import "responsive-utilities.less"; 51 | 52 | // a.haskellcn.org classes 53 | @import "../hcn/hcn.less"; 54 | -------------------------------------------------------------------------------- /static/bootstrap/breadcrumbs.less: -------------------------------------------------------------------------------- 1 | // 2 | // Breadcrumbs 3 | // -------------------------------------------------- 4 | 5 | 6 | .breadcrumb { 7 | padding: @breadcrumb-padding-vertical @breadcrumb-padding-horizontal; 8 | margin-bottom: @line-height-computed; 9 | list-style: none; 10 | background-color: @breadcrumb-bg; 11 | border-radius: @border-radius-base; 12 | 13 | > li { 14 | display: inline-block; 15 | 16 | + li:before { 17 | content: "@{breadcrumb-separator}\00a0"; // Unicode space added since inline-block means non-collapsing white-space 18 | padding: 0 5px; 19 | color: @breadcrumb-color; 20 | } 21 | } 22 | 23 | > .active { 24 | color: @breadcrumb-active-color; 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /static/bootstrap/buttons.less: -------------------------------------------------------------------------------- 1 | // 2 | // Buttons 3 | // -------------------------------------------------- 4 | 5 | 6 | // Base styles 7 | // -------------------------------------------------- 8 | 9 | .btn { 10 | display: inline-block; 11 | margin-bottom: 0; // For input.btn 12 | font-weight: @btn-font-weight; 13 | text-align: center; 14 | vertical-align: middle; 15 | cursor: pointer; 16 | background-image: none; // Reset unusual Firefox-on-Android default style; see https://github.com/necolas/normalize.css/issues/214 17 | border: 1px solid transparent; 18 | white-space: nowrap; 19 | .button-size(@padding-base-vertical; @padding-base-horizontal; @font-size-base; @line-height-base; @border-radius-base); 20 | .user-select(none); 21 | 22 | &, 23 | &:active, 24 | &.active { 25 | &:focus { 26 | .tab-focus(); 27 | } 28 | } 29 | 30 | &:hover, 31 | &:focus { 32 | color: @btn-default-color; 33 | text-decoration: none; 34 | } 35 | 36 | &:active, 37 | &.active { 38 | outline: 0; 39 | background-image: none; 40 | .box-shadow(inset 0 3px 5px rgba(0,0,0,.125)); 41 | } 42 | 43 | &.disabled, 44 | &[disabled], 45 | fieldset[disabled] & { 46 | cursor: not-allowed; 47 | pointer-events: none; // Future-proof disabling of clicks 48 | .opacity(.65); 49 | .box-shadow(none); 50 | } 51 | } 52 | 53 | 54 | // Alternate buttons 55 | // -------------------------------------------------- 56 | 57 | .btn-default { 58 | .button-variant(@btn-default-color; @btn-default-bg; @btn-default-border); 59 | } 60 | .btn-primary { 61 | .button-variant(@btn-primary-color; @btn-primary-bg; @btn-primary-border); 62 | } 63 | // Success appears as green 64 | .btn-success { 65 | .button-variant(@btn-success-color; @btn-success-bg; @btn-success-border); 66 | } 67 | // Info appears as blue-green 68 | .btn-info { 69 | .button-variant(@btn-info-color; @btn-info-bg; @btn-info-border); 70 | } 71 | // Warning appears as orange 72 | .btn-warning { 73 | .button-variant(@btn-warning-color; @btn-warning-bg; @btn-warning-border); 74 | } 75 | // Danger and error appear as red 76 | .btn-danger { 77 | .button-variant(@btn-danger-color; @btn-danger-bg; @btn-danger-border); 78 | } 79 | 80 | 81 | // Link buttons 82 | // ------------------------- 83 | 84 | // Make a button look and behave like a link 85 | .btn-link { 86 | color: @link-color; 87 | font-weight: normal; 88 | cursor: pointer; 89 | border-radius: 0; 90 | 91 | &, 92 | &:active, 93 | &[disabled], 94 | fieldset[disabled] & { 95 | background-color: transparent; 96 | .box-shadow(none); 97 | } 98 | &, 99 | &:hover, 100 | &:focus, 101 | &:active { 102 | border-color: transparent; 103 | } 104 | &:hover, 105 | &:focus { 106 | color: @link-hover-color; 107 | text-decoration: underline; 108 | background-color: transparent; 109 | } 110 | &[disabled], 111 | fieldset[disabled] & { 112 | &:hover, 113 | &:focus { 114 | color: @btn-link-disabled-color; 115 | text-decoration: none; 116 | } 117 | } 118 | } 119 | 120 | 121 | // Button Sizes 122 | // -------------------------------------------------- 123 | 124 | .btn-lg { 125 | // line-height: ensure even-numbered height of button next to large input 126 | .button-size(@padding-large-vertical; @padding-large-horizontal; @font-size-large; @line-height-large; @border-radius-large); 127 | } 128 | .btn-sm { 129 | // line-height: ensure proper height of button next to small input 130 | .button-size(@padding-small-vertical; @padding-small-horizontal; @font-size-small; @line-height-small; @border-radius-small); 131 | } 132 | .btn-xs { 133 | .button-size(@padding-xs-vertical; @padding-xs-horizontal; @font-size-small; @line-height-small; @border-radius-small); 134 | } 135 | 136 | 137 | // Block button 138 | // -------------------------------------------------- 139 | 140 | .btn-block { 141 | display: block; 142 | width: 100%; 143 | padding-left: 0; 144 | padding-right: 0; 145 | } 146 | 147 | // Vertically space out multiple block buttons 148 | .btn-block + .btn-block { 149 | margin-top: 5px; 150 | } 151 | 152 | // Specificity overrides 153 | input[type="submit"], 154 | input[type="reset"], 155 | input[type="button"] { 156 | &.btn-block { 157 | width: 100%; 158 | } 159 | } 160 | -------------------------------------------------------------------------------- /static/bootstrap/close.less: -------------------------------------------------------------------------------- 1 | // 2 | // Close icons 3 | // -------------------------------------------------- 4 | 5 | 6 | .close { 7 | float: right; 8 | font-size: (@font-size-base * 1.5); 9 | font-weight: @close-font-weight; 10 | line-height: 1; 11 | color: @close-color; 12 | text-shadow: @close-text-shadow; 13 | .opacity(.2); 14 | 15 | &:hover, 16 | &:focus { 17 | color: @close-color; 18 | text-decoration: none; 19 | cursor: pointer; 20 | .opacity(.5); 21 | } 22 | 23 | // Additional properties for button version 24 | // iOS requires the button element instead of an anchor tag. 25 | // If you want the anchor version, it requires `href="#"`. 26 | button& { 27 | padding: 0; 28 | cursor: pointer; 29 | background: transparent; 30 | border: 0; 31 | -webkit-appearance: none; 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /static/bootstrap/code.less: -------------------------------------------------------------------------------- 1 | // 2 | // Code (inline and block) 3 | // -------------------------------------------------- 4 | 5 | 6 | // Inline and block code styles 7 | code, 8 | kbd, 9 | pre, 10 | samp { 11 | font-family: @font-family-monospace; 12 | } 13 | 14 | // Inline code 15 | code { 16 | padding: 2px 4px; 17 | font-size: 90%; 18 | color: @code-color; 19 | background-color: @code-bg; 20 | border-radius: @border-radius-base; 21 | } 22 | 23 | // User input typically entered via keyboard 24 | kbd { 25 | padding: 2px 4px; 26 | font-size: 90%; 27 | color: @kbd-color; 28 | background-color: @kbd-bg; 29 | border-radius: @border-radius-small; 30 | box-shadow: inset 0 -1px 0 rgba(0,0,0,.25); 31 | } 32 | 33 | // Blocks of code 34 | pre { 35 | display: block; 36 | padding: ((@line-height-computed - 1) / 2); 37 | margin: 0 0 (@line-height-computed / 2); 38 | font-size: (@font-size-base - 1); // 14px to 13px 39 | line-height: @line-height-base; 40 | word-break: break-all; 41 | word-wrap: break-word; 42 | color: @pre-color; 43 | background-color: @pre-bg; 44 | border: 1px solid @pre-border-color; 45 | border-radius: @border-radius-base; 46 | 47 | // Account for some code outputs that place code tags in pre tags 48 | code { 49 | padding: 0; 50 | font-size: inherit; 51 | color: inherit; 52 | white-space: pre-wrap; 53 | background-color: transparent; 54 | border-radius: 0; 55 | } 56 | } 57 | 58 | // Enable scrollable blocks of code 59 | .pre-scrollable { 60 | max-height: @pre-scrollable-max-height; 61 | overflow-y: scroll; 62 | } 63 | -------------------------------------------------------------------------------- /static/bootstrap/component-animations.less: -------------------------------------------------------------------------------- 1 | // 2 | // Component animations 3 | // -------------------------------------------------- 4 | 5 | // Heads up! 6 | // 7 | // We don't use the `.opacity()` mixin here since it causes a bug with text 8 | // fields in IE7-8. Source: https://github.com/twbs/bootstrap/pull/3552. 9 | 10 | .fade { 11 | opacity: 0; 12 | .transition(opacity .15s linear); 13 | &.in { 14 | opacity: 1; 15 | } 16 | } 17 | 18 | .collapse { 19 | display: none; 20 | 21 | &.in { display: block; } 22 | tr&.in { display: table-row; } 23 | tbody&.in { display: table-row-group; } 24 | } 25 | 26 | .collapsing { 27 | position: relative; 28 | height: 0; 29 | overflow: hidden; 30 | .transition(height .35s ease); 31 | } 32 | -------------------------------------------------------------------------------- /static/bootstrap/grid.less: -------------------------------------------------------------------------------- 1 | // 2 | // Grid system 3 | // -------------------------------------------------- 4 | 5 | 6 | // Container widths 7 | // 8 | // Set the container width, and override it for fixed navbars in media queries. 9 | 10 | .container { 11 | .container-fixed(); 12 | 13 | @media (min-width: @screen-sm-min) { 14 | width: @container-sm; 15 | } 16 | @media (min-width: @screen-md-min) { 17 | width: @container-md; 18 | } 19 | @media (min-width: @screen-lg-min) { 20 | width: @container-lg; 21 | } 22 | } 23 | 24 | 25 | // Fluid container 26 | // 27 | // Utilizes the mixin meant for fixed width containers, but without any defined 28 | // width for fluid, full width layouts. 29 | 30 | .container-fluid { 31 | .container-fixed(); 32 | } 33 | 34 | 35 | // Row 36 | // 37 | // Rows contain and clear the floats of your columns. 38 | 39 | .row { 40 | .make-row(); 41 | } 42 | 43 | 44 | // Columns 45 | // 46 | // Common styles for small and large grid columns 47 | 48 | .make-grid-columns(); 49 | 50 | 51 | // Extra small grid 52 | // 53 | // Columns, offsets, pushes, and pulls for extra small devices like 54 | // smartphones. 55 | 56 | .make-grid(xs); 57 | 58 | 59 | // Small grid 60 | // 61 | // Columns, offsets, pushes, and pulls for the small device range, from phones 62 | // to tablets. 63 | 64 | @media (min-width: @screen-sm-min) { 65 | .make-grid(sm); 66 | } 67 | 68 | 69 | // Medium grid 70 | // 71 | // Columns, offsets, pushes, and pulls for the desktop device range. 72 | 73 | @media (min-width: @screen-md-min) { 74 | .make-grid(md); 75 | } 76 | 77 | 78 | // Large grid 79 | // 80 | // Columns, offsets, pushes, and pulls for the large desktop device range. 81 | 82 | @media (min-width: @screen-lg-min) { 83 | .make-grid(lg); 84 | } 85 | -------------------------------------------------------------------------------- /static/bootstrap/jumbotron.less: -------------------------------------------------------------------------------- 1 | // 2 | // Jumbotron 3 | // -------------------------------------------------- 4 | 5 | 6 | .jumbotron { 7 | padding: @jumbotron-padding; 8 | margin-bottom: @jumbotron-padding; 9 | color: @jumbotron-color; 10 | background-color: @jumbotron-bg; 11 | 12 | h1, 13 | .h1 { 14 | color: @jumbotron-heading-color; 15 | } 16 | p { 17 | margin-bottom: (@jumbotron-padding / 2); 18 | font-size: @jumbotron-font-size; 19 | font-weight: 200; 20 | } 21 | 22 | > hr { 23 | border-top-color: darken(@jumbotron-bg, 10%); 24 | } 25 | 26 | .container & { 27 | border-radius: @border-radius-large; // Only round corners at higher resolutions if contained in a container 28 | } 29 | 30 | .container { 31 | max-width: 100%; 32 | } 33 | 34 | @media screen and (min-width: @screen-sm-min) { 35 | padding-top: (@jumbotron-padding * 1.6); 36 | padding-bottom: (@jumbotron-padding * 1.6); 37 | 38 | .container & { 39 | padding-left: (@jumbotron-padding * 2); 40 | padding-right: (@jumbotron-padding * 2); 41 | } 42 | 43 | h1, 44 | .h1 { 45 | font-size: (@font-size-base * 4.5); 46 | } 47 | } 48 | } 49 | -------------------------------------------------------------------------------- /static/bootstrap/labels.less: -------------------------------------------------------------------------------- 1 | // 2 | // Labels 3 | // -------------------------------------------------- 4 | 5 | .label { 6 | display: inline; 7 | padding: .2em .6em .3em; 8 | font-size: 75%; 9 | font-weight: bold; 10 | line-height: 1; 11 | color: @label-color; 12 | text-align: center; 13 | white-space: nowrap; 14 | vertical-align: baseline; 15 | border-radius: .25em; 16 | 17 | // Add hover effects, but only for links 18 | a& { 19 | &:hover, 20 | &:focus { 21 | color: @label-link-hover-color; 22 | text-decoration: none; 23 | cursor: pointer; 24 | } 25 | } 26 | 27 | // Empty labels collapse automatically (not available in IE8) 28 | &:empty { 29 | display: none; 30 | } 31 | 32 | // Quick fix for labels in buttons 33 | .btn & { 34 | position: relative; 35 | top: -1px; 36 | } 37 | } 38 | 39 | // Colors 40 | // Contextual variations (linked labels get darker on :hover) 41 | 42 | .label-default { 43 | .label-variant(@label-default-bg); 44 | } 45 | 46 | .label-primary { 47 | .label-variant(@label-primary-bg); 48 | } 49 | 50 | .label-success { 51 | .label-variant(@label-success-bg); 52 | } 53 | 54 | .label-info { 55 | .label-variant(@label-info-bg); 56 | } 57 | 58 | .label-warning { 59 | .label-variant(@label-warning-bg); 60 | } 61 | 62 | .label-danger { 63 | .label-variant(@label-danger-bg); 64 | } 65 | -------------------------------------------------------------------------------- /static/bootstrap/list-group.less: -------------------------------------------------------------------------------- 1 | // 2 | // List groups 3 | // -------------------------------------------------- 4 | 5 | 6 | // Base class 7 | // 8 | // Easily usable on
    ,
      , or
      . 9 | 10 | .list-group { 11 | // No need to set list-style: none; since .list-group-item is block level 12 | margin-bottom: 20px; 13 | padding-left: 0; // reset padding because ul and ol 14 | } 15 | 16 | 17 | // Individual list items 18 | // 19 | // Use on `li`s or `div`s within the `.list-group` parent. 20 | 21 | .list-group-item { 22 | position: relative; 23 | display: block; 24 | padding: 10px 15px; 25 | // Place the border on the list items and negative margin up for better styling 26 | margin-bottom: -1px; 27 | background-color: @list-group-bg; 28 | border: 1px solid @list-group-border; 29 | 30 | // Round the first and last items 31 | &:first-child { 32 | .border-top-radius(@list-group-border-radius); 33 | } 34 | &:last-child { 35 | margin-bottom: 0; 36 | .border-bottom-radius(@list-group-border-radius); 37 | } 38 | 39 | // Align badges within list items 40 | > .badge { 41 | float: right; 42 | } 43 | > .badge + .badge { 44 | margin-right: 5px; 45 | } 46 | } 47 | 48 | 49 | // Linked list items 50 | // 51 | // Use anchor elements instead of `li`s or `div`s to create linked list items. 52 | // Includes an extra `.active` modifier class for showing selected items. 53 | 54 | a.list-group-item { 55 | color: @list-group-link-color; 56 | 57 | .list-group-item-heading { 58 | color: @list-group-link-heading-color; 59 | } 60 | 61 | // Hover state 62 | &:hover, 63 | &:focus { 64 | text-decoration: none; 65 | color: @list-group-link-hover-color; 66 | background-color: @list-group-hover-bg; 67 | } 68 | } 69 | 70 | .list-group-item { 71 | // Disabled state 72 | &.disabled, 73 | &.disabled:hover, 74 | &.disabled:focus { 75 | background-color: @list-group-disabled-bg; 76 | color: @list-group-disabled-color; 77 | 78 | // Force color to inherit for custom content 79 | .list-group-item-heading { 80 | color: inherit; 81 | } 82 | .list-group-item-text { 83 | color: @list-group-disabled-text-color; 84 | } 85 | } 86 | 87 | // Active class on item itself, not parent 88 | &.active, 89 | &.active:hover, 90 | &.active:focus { 91 | z-index: 2; // Place active items above their siblings for proper border styling 92 | color: @list-group-active-color; 93 | background-color: @list-group-active-bg; 94 | border-color: @list-group-active-border; 95 | 96 | // Force color to inherit for custom content 97 | .list-group-item-heading { 98 | color: inherit; 99 | } 100 | .list-group-item-text { 101 | color: @list-group-active-text-color; 102 | } 103 | } 104 | } 105 | 106 | 107 | // Contextual variants 108 | // 109 | // Add modifier classes to change text and background color on individual items. 110 | // Organizationally, this must come after the `:hover` states. 111 | 112 | .list-group-item-variant(success; @state-success-bg; @state-success-text); 113 | .list-group-item-variant(info; @state-info-bg; @state-info-text); 114 | .list-group-item-variant(warning; @state-warning-bg; @state-warning-text); 115 | .list-group-item-variant(danger; @state-danger-bg; @state-danger-text); 116 | 117 | 118 | // Custom content options 119 | // 120 | // Extra classes for creating well-formatted content within `.list-group-item`s. 121 | 122 | .list-group-item-heading { 123 | margin-top: 0; 124 | margin-bottom: 5px; 125 | } 126 | .list-group-item-text { 127 | margin-bottom: 0; 128 | line-height: 1.3; 129 | } 130 | -------------------------------------------------------------------------------- /static/bootstrap/media.less: -------------------------------------------------------------------------------- 1 | // Media objects 2 | // Source: http://stubbornella.org/content/?p=497 3 | // -------------------------------------------------- 4 | 5 | 6 | // Common styles 7 | // ------------------------- 8 | 9 | // Clear the floats 10 | .media, 11 | .media-body { 12 | overflow: hidden; 13 | zoom: 1; 14 | } 15 | 16 | // Proper spacing between instances of .media 17 | .media, 18 | .media .media { 19 | margin-top: 15px; 20 | } 21 | .media:first-child { 22 | margin-top: 0; 23 | } 24 | 25 | // For images and videos, set to block 26 | .media-object { 27 | display: block; 28 | } 29 | 30 | // Reset margins on headings for tighter default spacing 31 | .media-heading { 32 | margin: 0 0 5px; 33 | } 34 | 35 | 36 | // Media image alignment 37 | // ------------------------- 38 | 39 | .media { 40 | > .pull-left { 41 | margin-right: 10px; 42 | } 43 | > .pull-right { 44 | margin-left: 10px; 45 | } 46 | } 47 | 48 | 49 | // Media list variation 50 | // ------------------------- 51 | 52 | // Undo default ul/ol styles 53 | .media-list { 54 | padding-left: 0; 55 | list-style: none; 56 | } 57 | -------------------------------------------------------------------------------- /static/bootstrap/mixins.less: -------------------------------------------------------------------------------- 1 | // Mixins 2 | // -------------------------------------------------- 3 | 4 | // Utilities 5 | @import "mixins/hide-text.less"; 6 | @import "mixins/opacity.less"; 7 | @import "mixins/image.less"; 8 | @import "mixins/labels.less"; 9 | @import "mixins/reset-filter.less"; 10 | @import "mixins/resize.less"; 11 | @import "mixins/responsive-visibility.less"; 12 | @import "mixins/size.less"; 13 | @import "mixins/tab-focus.less"; 14 | @import "mixins/text-emphasis.less"; 15 | @import "mixins/text-overflow.less"; 16 | @import "mixins/vendor-prefixes.less"; 17 | 18 | // Components 19 | @import "mixins/alerts.less"; 20 | @import "mixins/buttons.less"; 21 | @import "mixins/panels.less"; 22 | @import "mixins/pagination.less"; 23 | @import "mixins/list-group.less"; 24 | @import "mixins/nav-divider.less"; 25 | @import "mixins/forms.less"; 26 | @import "mixins/progress-bar.less"; 27 | @import "mixins/table-row.less"; 28 | 29 | // Skins 30 | @import "mixins/background-variant.less"; 31 | @import "mixins/border-radius.less"; 32 | @import "mixins/gradients.less"; 33 | 34 | // Layout 35 | @import "mixins/clearfix.less"; 36 | @import "mixins/center-block.less"; 37 | @import "mixins/nav-vertical-align.less"; 38 | @import "mixins/grid-framework.less"; 39 | @import "mixins/grid.less"; 40 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/alerts.less: -------------------------------------------------------------------------------- 1 | // Alerts 2 | 3 | .alert-variant(@background; @border; @text-color) { 4 | background-color: @background; 5 | border-color: @border; 6 | color: @text-color; 7 | 8 | hr { 9 | border-top-color: darken(@border, 5%); 10 | } 11 | .alert-link { 12 | color: darken(@text-color, 10%); 13 | } 14 | } 15 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/background-variant.less: -------------------------------------------------------------------------------- 1 | // Contextual backgrounds 2 | 3 | .bg-variant(@color) { 4 | background-color: @color; 5 | a&:hover { 6 | background-color: darken(@color, 10%); 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/border-radius.less: -------------------------------------------------------------------------------- 1 | // Single side border-radius 2 | 3 | .border-top-radius(@radius) { 4 | border-top-right-radius: @radius; 5 | border-top-left-radius: @radius; 6 | } 7 | .border-right-radius(@radius) { 8 | border-bottom-right-radius: @radius; 9 | border-top-right-radius: @radius; 10 | } 11 | .border-bottom-radius(@radius) { 12 | border-bottom-right-radius: @radius; 13 | border-bottom-left-radius: @radius; 14 | } 15 | .border-left-radius(@radius) { 16 | border-bottom-left-radius: @radius; 17 | border-top-left-radius: @radius; 18 | } 19 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/buttons.less: -------------------------------------------------------------------------------- 1 | // Button variants 2 | // 3 | // Easily pump out default styles, as well as :hover, :focus, :active, 4 | // and disabled options for all buttons 5 | 6 | .button-variant(@color; @background; @border) { 7 | color: @color; 8 | background-color: @background; 9 | border-color: @border; 10 | 11 | &:hover, 12 | &:focus, 13 | &:active, 14 | &.active, 15 | .open > .dropdown-toggle& { 16 | color: @color; 17 | background-color: darken(@background, 10%); 18 | border-color: darken(@border, 12%); 19 | } 20 | &:active, 21 | &.active, 22 | .open > .dropdown-toggle& { 23 | background-image: none; 24 | } 25 | &.disabled, 26 | &[disabled], 27 | fieldset[disabled] & { 28 | &, 29 | &:hover, 30 | &:focus, 31 | &:active, 32 | &.active { 33 | background-color: @background; 34 | border-color: @border; 35 | } 36 | } 37 | 38 | .badge { 39 | color: @background; 40 | background-color: @color; 41 | } 42 | } 43 | 44 | // Button sizes 45 | .button-size(@padding-vertical; @padding-horizontal; @font-size; @line-height; @border-radius) { 46 | padding: @padding-vertical @padding-horizontal; 47 | font-size: @font-size; 48 | line-height: @line-height; 49 | border-radius: @border-radius; 50 | } 51 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/center-block.less: -------------------------------------------------------------------------------- 1 | // Center-align a block level element 2 | 3 | .center-block() { 4 | display: block; 5 | margin-left: auto; 6 | margin-right: auto; 7 | } 8 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/clearfix.less: -------------------------------------------------------------------------------- 1 | // Clearfix 2 | // 3 | // For modern browsers 4 | // 1. The space content is one way to avoid an Opera bug when the 5 | // contenteditable attribute is included anywhere else in the document. 6 | // Otherwise it causes space to appear at the top and bottom of elements 7 | // that are clearfixed. 8 | // 2. The use of `table` rather than `block` is only necessary if using 9 | // `:before` to contain the top-margins of child elements. 10 | // 11 | // Source: http://nicolasgallagher.com/micro-clearfix-hack/ 12 | 13 | .clearfix() { 14 | &:before, 15 | &:after { 16 | content: " "; // 1 17 | display: table; // 2 18 | } 19 | &:after { 20 | clear: both; 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /static/bootstrap/mixins/forms.less: -------------------------------------------------------------------------------- 1 | // Form validation states 2 | // 3 | // Used in forms.less to generate the form validation CSS for warnings, errors, 4 | // and successes. 5 | 6 | .form-control-validation(@text-color: #555; @border-color: #ccc; @background-color: #f5f5f5) { 7 | // Color the label and help text 8 | .help-block, 9 | .control-label, 10 | .radio, 11 | .checkbox, 12 | .radio-inline, 13 | .checkbox-inline { 14 | color: @text-color; 15 | } 16 | // Set the border and box shadow on specific inputs to match 17 | .form-control { 18 | border-color: @border-color; 19 | .box-shadow(inset 0 1px 1px rgba(0,0,0,.075)); // Redeclare so transitions work 20 | &:focus { 21 | border-color: darken(@border-color, 10%); 22 | @shadow: inset 0 1px 1px rgba(0,0,0,.075), 0 0 6px lighten(@border-color, 20%); 23 | .box-shadow(@shadow); 24 | } 25 | } 26 | // Set validation states also for addons 27 | .input-group-addon { 28 | color: @text-color; 29 | border-color: @border-color; 30 | background-color: @background-color; 31 | } 32 | // Optional feedback icon 33 | .form-control-feedback { 34 | color: @text-color; 35 | } 36 | } 37 | 38 | 39 | // Form control focus state 40 | // 41 | // Generate a customized focus state and for any input with the specified color, 42 | // which defaults to the `@input-border-focus` variable. 43 | // 44 | // We highly encourage you to not customize the default value, but instead use 45 | // this to tweak colors on an as-needed basis. This aesthetic change is based on 46 | // WebKit's default styles, but applicable to a wider range of browsers. Its 47 | // usability and accessibility should be taken into account with any change. 48 | // 49 | // Example usage: change the default blue border and shadow to white for better 50 | // contrast against a dark gray background. 51 | .form-control-focus(@color: @input-border-focus) { 52 | @color-rgba: rgba(red(@color), green(@color), blue(@color), .6); 53 | &:focus { 54 | border-color: @color; 55 | outline: 0; 56 | .box-shadow(~"inset 0 1px 1px rgba(0,0,0,.075), 0 0 8px @{color-rgba}"); 57 | } 58 | } 59 | 60 | // Form control sizing 61 | // 62 | // Relative text size, padding, and border-radii changes for form controls. For 63 | // horizontal sizing, wrap controls in the predefined grid classes. `