├── static ├── favicon.ico ├── img │ ├── glyphicons-halflings.png │ └── glyphicons-halflings-white.png ├── css │ ├── application.css │ └── bootstrap.min.css └── js │ ├── flash.js │ ├── jquery.cookie.js │ ├── bootstrap-typeahead.js │ ├── bootstrap.min.js │ └── bootstrap.js ├── .gitignore ├── README.md ├── Setup.hs ├── .env ├── LICENSE ├── hails-auth.cabal ├── Layouts.hs ├── Models.hs ├── Main.hs ├── Utils.hs ├── Views.hs └── Controllers.hs /static/favicon.ico: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hails-auth 2 | ========== 3 | 4 | Hails authentication system -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main :: IO () 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /.env: -------------------------------------------------------------------------------- 1 | PORT=8000 2 | HMAC_KEY=w00t 3 | COOKIE_DOMAIN=.lvh.me 4 | BRAND=Gitstar 5 | BRAND_URL=http://gitstar.lvh.me:8080 6 | -------------------------------------------------------------------------------- /static/img/glyphicons-halflings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails-auth/master/static/img/glyphicons-halflings.png -------------------------------------------------------------------------------- /static/img/glyphicons-halflings-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails-auth/master/static/img/glyphicons-halflings-white.png -------------------------------------------------------------------------------- /static/css/application.css: -------------------------------------------------------------------------------- 1 | @import url(https://fonts.googleapis.com/css?family=Ubuntu:400,700,400italic,700italic|Inika:400,700); 2 | .create { 3 | float: right; 4 | } 5 | 6 | body { 7 | padding-top: 60px; 8 | font-family: "Inika", serif; 9 | } 10 | 11 | p { 12 | font-family: "Ubuntu", sans-serif; 13 | font-size: 110%; 14 | } 15 | .nav-pills { 16 | border-bottom: 1px solid #ccc; 17 | } 18 | 19 | .nav-pills > li a { 20 | font-family: "Ubuntu", sans-serif; 21 | border: 1px solid #ccc; 22 | border-right: 1px solid #ccc; 23 | } 24 | 25 | .nav-pills > .active a { 26 | border: 0px; 27 | } 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This program is free software; you can redistribute it and/or 2 | modify it under the terms of the GNU General Public License as 3 | published by the Free Software Foundation; either version 2, or (at 4 | your option) any later version. 5 | 6 | This program is distributed in the hope that it will be useful, but 7 | WITHOUT ANY WARRANTY; without even the implied warranty of 8 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 9 | General Public License for more details. 10 | 11 | You can obtain copies of permitted licenses from these URLs: 12 | 13 | http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt 14 | http://www.gnu.org/licenses/gpl-3.0.txt 15 | 16 | or by writing to the Free Software Foundation, Inc., 59 Temple Place, 17 | Suite 330, Boston, MA 02111-1307 USA 18 | -------------------------------------------------------------------------------- /static/js/flash.js: -------------------------------------------------------------------------------- 1 | /* This is an implementation of error, success, and info alerts 2 | * compatible with bootstrap.js. The current implementation relies on 3 | * cookies and HTML5 session storage. The former is used by the server 4 | * to set a _flash-* key to the message value; the latter is used to 5 | * keep track of which messages have been displayed. The cookie is 6 | * immediately delete, while the session storage item persists until 7 | * the window is closed. */ 8 | 9 | $(function () { 10 | 11 | var flash = function (type, handler) { 12 | var flash_type ='_flash-'+type; 13 | if($.cookie(flash_type)) { 14 | var flash = $.cookie(flash_type).slice(1,-1).split('|'); 15 | var oid = flash[0]; // get unique message id 16 | var msg = flash[1]; // get actual message 17 | if(window.sessionStorage.getItem(oid) == null ) { 18 | window.sessionStorage.setItem(oid, '1'); 19 | $.cookie(flash_type, null); // delete the cookie 20 | $("#flash-messages").append( 21 | '
' 22 | +'×' 23 | + handler(msg) 24 | + '
'); 25 | } 26 | } 27 | } 28 | 29 | flash('error', function (msg){ return 'Error:' + msg; }); 30 | flash('success', function (msg){ return 'Success:' + msg; }); 31 | flash('info', function (msg){ return msg; }); 32 | 33 | }); 34 | -------------------------------------------------------------------------------- /hails-auth.cabal: -------------------------------------------------------------------------------- 1 | Name: hails-auth 2 | Version: 0.1.2 3 | build-type: Simple 4 | License: GPL-2 5 | License-File: LICENSE 6 | Author: HAILS team 7 | Maintainer: Amit Levy , Deian Stefan 8 | Stability: experimental 9 | Synopsis: Authentication app for Hails platforms 10 | Category: Web 11 | Cabal-Version: >= 1.8 12 | 13 | Description: 14 | Authentication app for Hails platforms 15 | 16 | Source-repository head 17 | Type: git 18 | Location: http://www.github.com/scslab/hails-bin.git 19 | 20 | Executable hails-auth 21 | Main-is: Main.hs 22 | ghc-options: -Wall -threaded 23 | Build-Depends: base >= 4.5 && < 5, 24 | regex-posix >= 0.95 && < 1.0, 25 | containers >= 0.4.2 && < 0.5, 26 | bytestring >= 0.9 && < 1, 27 | containers >= 0.4.2 && < 0.5, 28 | iterIO >= 0.2.2 && < 0.3, 29 | iterio-server >= 0.3.1 && < 0.4, 30 | HsOpenSSL >= 0.10.1 && < 2, 31 | mongoDB >= 1.1.2 && < 1.3, 32 | structured-mongoDB >= 0.3 && < 1.0, 33 | bson >= 0.1 && < 0.2, 34 | transformers >= 0.2.2.0 && < 0.3, 35 | blaze-html >= 0.4.3.3 && < 0.5, 36 | bcrypt >= 0.0.3 && < 0.1, 37 | SHA >= 1.5 && < 2, 38 | mtl >= 2.0 && < 2.1 39 | -------------------------------------------------------------------------------- /Layouts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Layouts where 4 | 5 | import Data.Maybe 6 | import Data.IterIO.Http.Support 7 | 8 | import Prelude hiding (head, id, div, span) 9 | import Text.Blaze.Html5 hiding (map) 10 | import Text.Blaze.Html5.Attributes hiding (title, span, content) 11 | import qualified Text.Blaze.Renderer.Utf8 as R (renderHtml) 12 | 13 | import Control.Monad.Trans 14 | import System.Environment 15 | 16 | renderHtml :: Html -> Action t b IO () 17 | renderHtml htmlBody = do 18 | env <- liftIO getEnvironment 19 | let brand = fromMaybe "Hails Authentication" $ lookup "BRAND" env 20 | brandUrl = fromMaybe "#" $ lookup "BRAND_URL" env 21 | render "text/html" $ R.renderHtml $ application brand brandUrl htmlBody 22 | 23 | stylesheet :: String -> Html 24 | stylesheet uri = link ! rel "stylesheet" ! type_ "text/css" ! href (toValue uri) 25 | 26 | application :: String -> String -> Html -> Html 27 | application brand brandUrl content = docTypeHtml $ 28 | head $ do 29 | title "GitStar" 30 | stylesheet "/css/bootstrap.css" 31 | stylesheet "/css/application.css" 32 | body $ do 33 | div ! class_ "navbar navbar-fixed-top" $ 34 | div ! class_ "navbar-inner" $ 35 | div ! class_ "container" $ 36 | a ! href (toValue brandUrl) ! class_ "brand" $ toHtml brand 37 | div ! class_ "row" $ 38 | div ! id "flash-messages" ! class_ "span4 offset4" $ "" 39 | div ! class_ "container" $ content 40 | script ! src "/js/jquery.js" $ "" 41 | script ! src "/js/jquery.cookie.js" $ "" 42 | script ! src "/js/bootstrap.min.js" $ "" 43 | script ! src "/js/bootstrap-typeahead.js" $ "" 44 | script ! src "/js/flash.js" $ "" 45 | -------------------------------------------------------------------------------- /Models.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | module Models ( User(..) 9 | , insertUser, insertUser_ 10 | , updateUser, findUser ) where 11 | 12 | import Data.Maybe 13 | 14 | import Data.Bson 15 | import Data.Typeable 16 | import Database.MongoDB.Structured 17 | import Database.MongoDB.Structured.Deriving.TH 18 | 19 | import Control.Monad 20 | import Control.Exception 21 | 22 | -- | Perform action on DB. This is slow because it always tears down 23 | -- the connection. 24 | withDB :: Action IO b -> IO b 25 | withDB act = do 26 | pipe <- runIOE $ connect (host "localhost") 27 | qr <- access pipe master "hails" act 28 | close pipe 29 | case qr of 30 | Right r -> return r 31 | Left e -> throwIO . userError $ "Failed with: " ++ show e 32 | 33 | data User = User { userId :: SObjId 34 | , userName :: String 35 | , userEmail :: String 36 | , userPassword :: String 37 | } deriving (Eq, Show, Typeable) 38 | $(deriveStructured ''User) 39 | 40 | -- | Insert a user into database 41 | insertUser :: User -> IO ObjectId 42 | insertUser user = withDB $ liftM (unSObjId . fromJust . cast') $ insert user 43 | 44 | -- | Insert a user into database 45 | insertUser_ :: User -> IO () 46 | insertUser_ user = withDB $ insert_ user 47 | 48 | -- | Save user into database 49 | updateUser :: User -> IO () 50 | updateUser user = withDB $ save user 51 | 52 | -- | Find existing user 53 | findUser :: String -> IO (Maybe User) 54 | findUser uName = withDB $ do 55 | let query = select (UserName .== uName) 56 | findOne query 57 | -------------------------------------------------------------------------------- /static/js/jquery.cookie.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * jQuery Cookie Plugin 3 | * https://github.com/carhartl/jquery-cookie 4 | * 5 | * Copyright 2011, Klaus Hartl 6 | * Dual licensed under the MIT or GPL Version 2 licenses. 7 | * http://www.opensource.org/licenses/mit-license.php 8 | * http://www.opensource.org/licenses/GPL-2.0 9 | */ 10 | (function($) { 11 | $.cookie = function(key, value, options) { 12 | 13 | // key and at least value given, set cookie... 14 | if (arguments.length > 1 && (!/Object/.test(Object.prototype.toString.call(value)) || value === null || value === undefined)) { 15 | options = $.extend({}, options); 16 | 17 | if (value === null || value === undefined) { 18 | options.expires = -1; 19 | } 20 | 21 | if (typeof options.expires === 'number') { 22 | var days = options.expires, t = options.expires = new Date(); 23 | t.setDate(t.getDate() + days); 24 | } 25 | 26 | value = String(value); 27 | 28 | return (document.cookie = [ 29 | encodeURIComponent(key), '=', options.raw ? value : encodeURIComponent(value), 30 | options.expires ? '; expires=' + options.expires.toUTCString() : '', // use expires attribute, max-age is not supported by IE 31 | options.path ? '; path=' + options.path : '', 32 | options.domain ? '; domain=' + options.domain : '', 33 | options.secure ? '; secure' : '' 34 | ].join('')); 35 | } 36 | 37 | // key and possibly options given, get cookie... 38 | options = value || {}; 39 | var decode = options.raw ? function(s) { return s; } : decodeURIComponent; 40 | 41 | var pairs = document.cookie.split('; '); 42 | for (var i = 0, pair; pair = pairs[i] && pairs[i].split('='); i++) { 43 | if (decode(pair[0]) === key) return decode(pair[1] || ''); // IE saves cookies with empty string as "c; ", e.g. without "=" as opposed to EOMB, thus pair[1] may be undefined 44 | } 45 | return null; 46 | }; 47 | })(jQuery); 48 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, OverloadedStrings, MultiParamTypeClasses #-} 2 | module Main (main) where 3 | import Control.Monad 4 | import Control.Exception (SomeException(..)) 5 | 6 | import qualified Data.ByteString.Char8 as S8 7 | import Data.Monoid 8 | import Data.Maybe 9 | 10 | import Data.IterIO 11 | import Data.IterIO.Http 12 | import Data.IterIO.HttpRoute (mimeTypesI) 13 | import Data.IterIO.SSL 14 | import Data.IterIO.Server.TCPServer 15 | import Data.IterIO.Http.Support 16 | 17 | import System.IO.Unsafe 18 | import System.Environment 19 | 20 | import OpenSSL (withOpenSSL) 21 | 22 | import Controllers 23 | import Utils 24 | 25 | main :: IO () 26 | main = withOpenSSL $ do 27 | env <- getEnvironment 28 | server <- case lookup "SSL_KEY_FILE" env of 29 | Nothing -> return simpleHttpServer 30 | Just f -> simpleHttpsServer `liftM` simpleContext f 31 | let port = fromMaybe 8000 $ lookup "PORT" env >>= maybeRead :: Int 32 | runTCPServer $ server (fromIntegral port) handler 33 | 34 | handler :: HttpRequestHandler IO () 35 | handler = runIterAction $ runActionRoute $ mconcat 36 | [ routeTop $ routeAction $ restIndex UsersController 37 | , routeRestController "users" UsersController 38 | , routeMethod "GET" $ routePattern "login" $ routeAction newLoginUser 39 | , routeMethod "POST" $ routePattern "login" $ routeAction loginUser 40 | , routeMethod "GET" $ routePattern "logout" $ routeAction logoutUser 41 | , routeFileSys mimeMap "static" 42 | ] 43 | 44 | 45 | -- | Given a file extension (e.g., \"hs\") return its MIME type (e.g., 46 | -- \"text\/x-haskell\"). If there is no recognized MIME type (or none 47 | -- of the default paths exist), this function returns 48 | -- \"application\/octet-stream\" 49 | mimeMap :: String -> S8.ByteString 50 | mimeMap = unsafePerformIO $ 51 | foldr1 cat (map enumMimeFile defaultPaths) |$ 52 | mimeTypesI "application/octet-stream" 53 | where defaultPaths = ["mime.types" 54 | , "/etc/mime.types" 55 | , "/var/www/conf/mime.types"] 56 | enumMimeFile f = inumCatch (enumFile f) $ \(SomeException _) res -> 57 | resumeI res 58 | -------------------------------------------------------------------------------- /Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #if PRODUCTION 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module Utils where 8 | 9 | import qualified Data.ByteString.Char8 as S8 10 | import qualified Data.ByteString.Lazy.Char8 as L8 11 | import Data.Maybe (listToMaybe, fromJust) 12 | 13 | import Data.IterIO.Http (reqCookies, respAddHeader) 14 | import Data.IterIO.Http.Support 15 | import Data.Bson (genObjectId) 16 | 17 | import Control.Monad 18 | import Control.Monad.Trans 19 | import Control.Monad.Trans.State 20 | 21 | 22 | -- | Force get parameter value 23 | getParamVal :: Monad m => S8.ByteString -> Action t b m String 24 | getParamVal n = (L8.unpack . paramValue . fromJust) `liftM` param n 25 | 26 | maybeRead :: Read a => String -> Maybe a 27 | maybeRead = fmap fst . listToMaybe . reads 28 | 29 | with404orJust :: Monad m => Maybe a -> (a -> Action t b m ()) -> Action t b m () 30 | with404orJust mval act = case mval of 31 | Nothing -> respond404 32 | Just val -> act val 33 | 34 | -- | Set the referer cookie (to referer) if unset. 35 | saveRefererIfNone :: Action t b IO () 36 | saveRefererIfNone = do 37 | mref <- getCookie "_hails_referer" 38 | mhdr <- fmap S8.unpack `liftM` requestHeader "referer" 39 | case (mref,mhdr) of 40 | (Nothing, Just u) -> setCookie "_hails_referer" (show u) 41 | _ -> return () 42 | 43 | -- | Redirect to the set refer, if set; or given URL. 44 | redirectToSavedRefererOrTo :: String -> Action t b IO () 45 | redirectToSavedRefererOrTo url = do 46 | mref <- getCookie "_hails_referer" 47 | redirectTo $ maybe url S8.unpack mref 48 | delCookie "_hails_referer" 49 | 50 | 51 | -- 52 | -- Flash notifications 53 | -- 54 | 55 | -- | This sets the @_flash-*@ cookie value to the given message, with 56 | -- a unique message ID. 57 | flash :: String -> String -> Action t b IO () 58 | flash n msg = do 59 | oid <- liftIO genObjectId 60 | setCookie ("_flash-" ++ n) (show (show oid ++ "|" ++ msg)) 61 | 62 | flashInfo :: String -> Action t b IO () 63 | flashInfo = flash "info" 64 | 65 | flashError :: String -> Action t b IO () 66 | flashError = flash "error" 67 | 68 | flashSuccess :: String -> Action t b IO () 69 | flashSuccess = flash "success" 70 | 71 | getCookie :: String -> Action t b IO (Maybe S8.ByteString) 72 | getCookie n = do 73 | req <- getHttpReq 74 | return $ lookup (S8.pack n) $ reqCookies req 75 | 76 | setCookie :: String -> String -> Action t b IO () 77 | setCookie n v = modify $ \s -> 78 | let cHeader = ( S8.pack "Set-Cookie" 79 | , S8.pack $ n ++ "=" ++ v ++ ";path=/;") 80 | in s { actionResp = respAddHeader cHeader (actionResp s)} 81 | 82 | delCookie :: String -> Action t b IO () 83 | delCookie n = modify $ \s -> 84 | let cHeader = ( S8.pack "Set-Cookie", S8.pack $ 85 | n ++ "=; path=/; expires=Thu, Jan 01 1970 00:00:00 UTC;") 86 | in s { actionResp = respAddHeader cHeader (actionResp s)} 87 | -------------------------------------------------------------------------------- /Views.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Views ( showView 6 | , loginView 7 | , newUser, editUser ) where 8 | 9 | import Prelude hiding (div, span, id) 10 | import Data.Monoid 11 | 12 | import Models 13 | 14 | import Text.Blaze.Html5 hiding (title) 15 | import Text.Blaze.Html5.Attributes hiding (label, form, span) 16 | 17 | -- | Show main page: edit account, logout 18 | showView :: String -> Html 19 | showView user = 20 | div ! class_ "hero-unit" $ do 21 | h1 $ toHtml $ "Welcome " ++ user ++ "!" 22 | p "It is a curious reason as to why you landed here." 23 | p $ do a ! href (toValue $ user ++ "/edit") 24 | ! class_ "btn btn-primary" $ "Edit account" 25 | " " 26 | a ! href "/logout" ! class_ "btn btn-inverse" $ "Log out" 27 | 28 | -- | Show login form 29 | loginView :: Maybe String -> Html 30 | loginView muName = 31 | form ! class_ "form-vertical" ! action "/login" ! method "POST" $ 32 | fieldset $ do 33 | legend $ do 34 | "Login" 35 | span ! class_ "create" $ do 36 | small "Don't have an account? " 37 | a ! class_ "btn btn-success" ! href "/users/new" $ "Register" 38 | label "User Name" 39 | input ! type_ "text" ! placeholder "ron_swanson" ! name "user_name" 40 | ! maybe mempty (value . toValue) muName 41 | label "Password" 42 | input ! type_ "password" ! name "password" 43 | div ! class_"form-actions" $ do 44 | input ! type_ "submit" ! class_ "btn btn-primary" ! value "Login" 45 | " " 46 | input ! type_ "reset" ! class_ "btn" ! value "Reset" 47 | 48 | -- | Show account registration form 49 | newUser :: Maybe User -> Html 50 | newUser muser = 51 | form ! class_ "form-vertical" ! action "/users" ! method "POST" $ 52 | fieldset $ do 53 | legend "Create a new account" 54 | label "User Name" 55 | input ! type_ "text" ! placeholder "ron" ! name "user_name" 56 | ! maybe mempty (value . toValue . userName) muser 57 | label "Email" 58 | input ! type_ "email" ! placeholder "ron@swanson.me" ! name "email" 59 | ! maybe mempty (value . toValue . userEmail) muser 60 | label "Password" 61 | input ! type_ "password" ! name "password" 62 | label "Password confirmation" 63 | input ! type_ "password" ! name "password_confirmation" 64 | div ! class_"form-actions" $ do 65 | input ! type_ "submit" ! class_ "btn btn-primary" ! value "Register" 66 | " " 67 | input ! type_ "reset" ! class_ "btn" ! value "Reset" 68 | 69 | -- | Show change email or password forms 70 | editUser :: User -> Html 71 | editUser user = do 72 | form ! class_ "form-vertical" 73 | ! action (toValue $ "/users/" ++ userName user) ! method "POST" $ 74 | fieldset $ do 75 | legend "Update email" 76 | input ! type_ "hidden" ! name "type" ! value "email" 77 | label "Email" 78 | input ! type_ "email" ! placeholder "ron@swanson.me" ! name "email" 79 | ! (value . toValue . userEmail $ user) 80 | div ! class_"form-actions" $ do 81 | input ! type_ "submit" ! class_ "btn btn-primary" ! value "Update email" 82 | " " 83 | input ! type_ "reset" ! class_ "btn" ! value "Reset" 84 | form ! class_ "form-vertical" 85 | ! action (toValue $ "/users/" ++ userName user) ! method "POST" $ 86 | fieldset $ do 87 | legend "Change password" 88 | input ! type_ "hidden" ! name "type" ! value "password" 89 | label "Old Password" 90 | input ! type_ "password" ! name "password_old" 91 | label "New Password" 92 | input ! type_ "password" ! name "password" 93 | label "Password confirmation" 94 | input ! type_ "password" ! name "password_confirmation" 95 | div ! class_"form-actions" $ do 96 | input ! type_ "submit" ! class_ "btn btn-primary" ! value "Change password" 97 | " " 98 | input ! type_ "reset" ! class_ "btn" ! value "Reset" 99 | -------------------------------------------------------------------------------- /static/js/bootstrap-typeahead.js: -------------------------------------------------------------------------------- 1 | /* ============================================================= 2 | * bootstrap-typeahead.js v2.0.0 3 | * http://twitter.github.com/bootstrap/javascript.html#typeahead 4 | * ============================================================= 5 | * Copyright 2012 Twitter, Inc. 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | * ============================================================ */ 19 | 20 | !function( $ ){ 21 | 22 | "use strict" 23 | 24 | var Typeahead = function ( element, options ) { 25 | this.$element = $(element) 26 | this.options = $.extend({}, $.fn.typeahead.defaults, options) 27 | this.matcher = this.options.matcher || this.matcher 28 | this.sorter = this.options.sorter || this.sorter 29 | this.highlighter = this.options.highlighter || this.highlighter 30 | this.$menu = $(this.options.menu).appendTo('body') 31 | this.source = this.options.source 32 | this.onselect = this.options.onselect 33 | this.strings = true 34 | this.shown = false 35 | this.listen() 36 | } 37 | 38 | Typeahead.prototype = { 39 | 40 | constructor: Typeahead 41 | 42 | , select: function () { 43 | var val = JSON.parse(this.$menu.find('.active').attr('data-value')) 44 | , text 45 | 46 | if (!this.strings) text = val[this.options.property] 47 | else text = val 48 | 49 | this.$element.val(text) 50 | 51 | if (typeof this.onselect == "function") 52 | this.onselect(val) 53 | 54 | return this.hide() 55 | } 56 | 57 | , show: function () { 58 | var pos = $.extend({}, this.$element.offset(), { 59 | height: this.$element[0].offsetHeight 60 | }) 61 | 62 | this.$menu.css({ 63 | top: pos.top + pos.height 64 | , left: pos.left 65 | }) 66 | 67 | this.$menu.show() 68 | this.shown = true 69 | return this 70 | } 71 | 72 | , hide: function () { 73 | this.$menu.hide() 74 | this.shown = false 75 | return this 76 | } 77 | 78 | , lookup: function (event) { 79 | var that = this 80 | , items 81 | , q 82 | , value 83 | 84 | this.query = this.$element.val() 85 | 86 | if (typeof this.source == "function") { 87 | value = this.source(this, this.query) 88 | if (value) this.process(value) 89 | } else { 90 | this.process(this.source) 91 | } 92 | } 93 | 94 | , process: function (results) { 95 | var that = this 96 | , items 97 | , q 98 | 99 | if (results.length && typeof results[0] != "string") 100 | this.strings = false 101 | 102 | this.query = this.$element.val() 103 | 104 | if (!this.query) { 105 | return this.shown ? this.hide() : this 106 | } 107 | 108 | items = $.grep(results, function (item) { 109 | if (!that.strings) 110 | item = item[that.options.property] 111 | if (that.matcher(item)) return item 112 | }) 113 | 114 | items = this.sorter(items) 115 | 116 | if (!items.length) { 117 | return this.shown ? this.hide() : this 118 | } 119 | 120 | return this.render(items.slice(0, this.options.items)).show() 121 | } 122 | 123 | , matcher: function (item) { 124 | return ~item.toLowerCase().indexOf(this.query.toLowerCase()) 125 | } 126 | 127 | , sorter: function (items) { 128 | var beginswith = [] 129 | , caseSensitive = [] 130 | , caseInsensitive = [] 131 | , item 132 | , sortby 133 | 134 | while (item = items.shift()) { 135 | if (this.strings) sortby = item 136 | else sortby = item[this.options.property] 137 | 138 | if (!sortby.toLowerCase().indexOf(this.query.toLowerCase())) beginswith.push(item) 139 | else if (~sortby.indexOf(this.query)) caseSensitive.push(item) 140 | else caseInsensitive.push(item) 141 | } 142 | 143 | return beginswith.concat(caseSensitive, caseInsensitive) 144 | } 145 | 146 | , highlighter: function (item) { 147 | return item.replace(new RegExp('(' + this.query + ')', 'ig'), function ($1, match) { 148 | return '' + match + '' 149 | }) 150 | } 151 | 152 | , render: function (items) { 153 | var that = this 154 | 155 | items = $(items).map(function (i, item) { 156 | i = $(that.options.item).attr('data-value', JSON.stringify(item)) 157 | if (!that.strings) 158 | item = item[that.options.property] 159 | i.find('a').html(that.highlighter(item)) 160 | return i[0] 161 | }) 162 | 163 | items.first().addClass('active') 164 | this.$menu.html(items) 165 | return this 166 | } 167 | 168 | , next: function (event) { 169 | var active = this.$menu.find('.active').removeClass('active') 170 | , next = active.next() 171 | 172 | if (!next.length) { 173 | next = $(this.$menu.find('li')[0]) 174 | } 175 | 176 | next.addClass('active') 177 | } 178 | 179 | , prev: function (event) { 180 | var active = this.$menu.find('.active').removeClass('active') 181 | , prev = active.prev() 182 | 183 | if (!prev.length) { 184 | prev = this.$menu.find('li').last() 185 | } 186 | 187 | prev.addClass('active') 188 | } 189 | 190 | , listen: function () { 191 | this.$element 192 | .on('blur', $.proxy(this.blur, this)) 193 | .on('keypress', $.proxy(this.keypress, this)) 194 | .on('keyup', $.proxy(this.keyup, this)) 195 | 196 | if ($.browser.webkit || $.browser.msie) { 197 | this.$element.on('keydown', $.proxy(this.keypress, this)) 198 | } 199 | 200 | this.$menu 201 | .on('click', $.proxy(this.click, this)) 202 | .on('mouseenter', 'li', $.proxy(this.mouseenter, this)) 203 | } 204 | 205 | , keyup: function (e) { 206 | e.stopPropagation() 207 | e.preventDefault() 208 | 209 | switch(e.keyCode) { 210 | case 40: // down arrow 211 | case 38: // up arrow 212 | break 213 | 214 | case 9: // tab 215 | case 13: // enter 216 | if (!this.shown) return 217 | this.select() 218 | break 219 | 220 | case 27: // escape 221 | this.hide() 222 | break 223 | 224 | default: 225 | this.lookup() 226 | } 227 | 228 | } 229 | 230 | , keypress: function (e) { 231 | e.stopPropagation() 232 | if (!this.shown) return 233 | 234 | switch(e.keyCode) { 235 | case 9: // tab 236 | case 13: // enter 237 | case 27: // escape 238 | e.preventDefault() 239 | break 240 | 241 | case 38: // up arrow 242 | e.preventDefault() 243 | this.prev() 244 | break 245 | 246 | case 40: // down arrow 247 | e.preventDefault() 248 | this.next() 249 | break 250 | } 251 | } 252 | 253 | , blur: function (e) { 254 | var that = this 255 | e.stopPropagation() 256 | e.preventDefault() 257 | setTimeout(function () { that.hide() }, 150) 258 | } 259 | 260 | , click: function (e) { 261 | e.stopPropagation() 262 | e.preventDefault() 263 | this.select() 264 | } 265 | 266 | , mouseenter: function (e) { 267 | this.$menu.find('.active').removeClass('active') 268 | $(e.currentTarget).addClass('active') 269 | } 270 | 271 | } 272 | 273 | 274 | /* TYPEAHEAD PLUGIN DEFINITION 275 | * =========================== */ 276 | 277 | $.fn.typeahead = function ( option ) { 278 | return this.each(function () { 279 | var $this = $(this) 280 | , data = $this.data('typeahead') 281 | , options = typeof option == 'object' && option 282 | if (!data) $this.data('typeahead', (data = new Typeahead(this, options))) 283 | if (typeof option == 'string') data[option]() 284 | }) 285 | } 286 | 287 | $.fn.typeahead.defaults = { 288 | source: [] 289 | , items: 8 290 | , menu: '' 291 | , item: '
  • ' 292 | , onselect: null 293 | , property: 'value' 294 | } 295 | 296 | $.fn.typeahead.Constructor = Typeahead 297 | 298 | 299 | /* TYPEAHEAD DATA-API 300 | * ================== */ 301 | 302 | $(function () { 303 | $('body').on('focus.typeahead.data-api', '[data-provide="typeahead"]', function (e) { 304 | var $this = $(this) 305 | if ($this.data('typeahead')) return 306 | e.preventDefault() 307 | $this.typeahead($this.data()) 308 | }) 309 | }) 310 | 311 | }( window.jQuery ); 312 | -------------------------------------------------------------------------------- /Controllers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Controllers ( UsersController(..) 7 | , loginUser, newLoginUser 8 | , logoutUser 9 | )where 10 | 11 | import Control.Monad.Trans 12 | 13 | import qualified Data.ByteString.Char8 as S8 14 | import qualified Data.ByteString.Lazy.Char8 as L8 15 | import Data.Maybe 16 | import Data.Digest.Pure.SHA 17 | 18 | import Data.IterIO.Http 19 | import Data.IterIO.Http.Support 20 | import Control.Monad 21 | 22 | import Database.MongoDB.Structured (noSObjId) 23 | 24 | import Crypto.BCrypt 25 | 26 | import Layouts 27 | import Models 28 | import Views 29 | import Utils 30 | 31 | import Text.Regex.Posix 32 | 33 | import System.Environment 34 | 35 | type L = L8.ByteString 36 | type S = S8.ByteString 37 | 38 | data UsersController = UsersController 39 | 40 | instance RestController t L IO UsersController where 41 | restIndex _ = do 42 | saveRefererIfNone 43 | euser <- getCurrentUserOr (renderHtml $ loginView Nothing) 44 | either id (redirectToSavedRefererOrTo . ("/users/" ++)) euser 45 | 46 | restShow _ _ = do 47 | saveRefererIfNone 48 | euser <- getCurrentUserOr (redirectToSavedRefererOrTo "/") 49 | either id (renderHtml . showView) euser 50 | 51 | restNew _ = renderHtml $ newUser Nothing 52 | 53 | restCreate _ = parseParams >> do 54 | env <- liftIO getEnvironment 55 | let m_hmac_key = lookup "HMAC_KEY" env 56 | mdomain = lookup "COOKIE_DOMAIN" env 57 | paramOrBack "user_name" $ \uName -> 58 | paramOrBack "email" $ \email -> 59 | paramOrBack "password" $ \pass0 -> 60 | paramOrBack "password_confirmation" $ \pass1 -> do 61 | let usr = User { userId = noSObjId 62 | , userName = uName 63 | , userEmail = email 64 | , userPassword = pass0 } 65 | exists <- liftIO $ userExists uName 66 | case () of 67 | _ | blank uName || blank email || blank pass0 -> 68 | mkEdit usr >> flashError "Fields cannot be blank." 69 | 70 | _ | pass0 /= pass1 -> 71 | mkEdit usr >> flashError "Passwords do not match." 72 | 73 | _ | not (wellformed uName) -> do 74 | mkEdit $ usr { userName = "" } 75 | flashError $ "Username must start with a letter and only" 76 | ++ " contain letters, numbers and underscore." 77 | 78 | _ | exists -> mkEdit usr >> flashError "Username taken" 79 | 80 | _ | isNothing m_hmac_key -> respondStat stat500 81 | 82 | _ -> do mpass <- liftIO $ bcrypt pass0 83 | case mpass of 84 | Nothing -> respondStat stat500 85 | Just pass -> do 86 | liftIO $ insertUser_ $ usr { userPassword = pass } 87 | redirectToSavedRefererOrTo "/" 88 | setCurrentUser (fromJust m_hmac_key) mdomain usr 89 | flashSuccess "Account created." 90 | 91 | where userExists uN = isJust `liftM` findUser uN 92 | mkEdit usr = renderHtml . newUser . Just $ usr { userPassword = "" } 93 | wellformed s = s =~ ("^[a-zA-Z][a-zA-Z0-9_]*" :: String) 94 | blank s = s =~ ("^\\s*$" :: String) 95 | 96 | restEdit _ _ = do 97 | euser <- getCurrentUserOr (respondStat stat403) 98 | either id (\uName -> do muser <- liftIO $ findUser uName 99 | maybe (respondStat stat403) 100 | (renderHtml . editUser) muser) euser 101 | 102 | restUpdate _ _ = parseParams >> do 103 | euser <- getCurrentUserOr (respondStat stat403) 104 | either id (\uName -> do muser <- liftIO $ findUser uName 105 | maybe (respondStat stat403) doUpdate muser) euser 106 | where blank s = s =~ ("^\\s*$" :: String) 107 | doUpdate user = paramOrBack "type" $ \type_ -> 108 | case type_ of 109 | "email" -> changeEmail user 110 | "password" -> changePassword user 111 | _ -> respondStat stat403 112 | changeEmail user = paramOrBack "email" $ \email -> do 113 | unless (blank email) $ 114 | liftIO $ updateUser $ user { userEmail = email } 115 | redirectBack 116 | if blank email 117 | then flashError "Email cannot be blank." 118 | else flashSuccess "Changed email address." 119 | changePassword user = 120 | paramOrBack "password_old" $ \pass0 -> 121 | paramOrBack "password" $ \pass1 -> 122 | paramOrBack "password_confirmation" $ \pass2 -> 123 | case () of 124 | _ | blank pass0 || blank pass1 -> 125 | redirectBack >> flashError "Password cannot be blank." 126 | 127 | _ | pass1 /= pass2 -> 128 | redirectBack >> flashError "Passwords do not match." 129 | 130 | _ | not $ validatePassword (S8.pack $ userPassword user) 131 | (S8.pack pass0) -> 132 | redirectBack >> flashError "Invalid password." 133 | _ -> do mpass <- liftIO $ bcrypt pass1 134 | case mpass of 135 | Nothing -> respondStat stat500 136 | Just pass -> do 137 | liftIO $ updateUser $ user { userPassword = pass } 138 | redirectBack 139 | flashSuccess "Password changed." 140 | 141 | 142 | 143 | -- | Controller for login 144 | -- POST /login 145 | loginUser :: Action t L IO () 146 | loginUser = parseParams >> do 147 | env <- liftIO getEnvironment 148 | let m_hmac_key = lookup "HMAC_KEY" env 149 | mdomain = lookup "COOKIE_DOMAIN" env 150 | paramOrBack "user_name" $ \uName -> 151 | paramOrBack "password" $ \pass -> do 152 | musr <- liftIO $ findUser uName 153 | let usr = fromJust musr -- takes advantage of Haskell's layzness 154 | case () of 155 | _ | isNothing musr -> mkLogin uName >> err 156 | _ | isNothing m_hmac_key -> respondStat stat500 157 | _ | not $ validatePassword (S8.pack $ userPassword usr) 158 | (S8.pack pass) -> mkLogin uName >> err 159 | _ -> do redirectToSavedRefererOrTo "/" 160 | setCurrentUser (fromJust m_hmac_key) mdomain usr 161 | where err = flashError "Unknown username/password." 162 | mkLogin = renderHtml . loginView . Just 163 | 164 | -- | GET /login 165 | newLoginUser :: Action t L IO () 166 | newLoginUser = renderHtml $ loginView Nothing 167 | 168 | -- | Controllerfor log out 169 | logoutUser :: Action t L IO () 170 | logoutUser = do 171 | delCookie "_hails_user" 172 | delCookie "_hails_user_hmac" 173 | delCookie "_hails_referer" 174 | redirectTo "/login" 175 | flashSuccess "Logged out." 176 | 177 | -- 178 | -- Helpers 179 | -- 180 | 181 | -- | Hash password with bcrypt 182 | bcrypt :: String -> IO (Maybe String) 183 | bcrypt pass = do 184 | mres <- hashPasswordUsingPolicy slowerBcryptHashingPolicy (S8.pack pass) 185 | return $ S8.unpack `liftM` mres 186 | 187 | 188 | -- | Setthe hails user cookies 189 | setCurrentUser :: String -> Maybe String -> User -> Action t b IO () 190 | setCurrentUser key mdomain usr = do 191 | let uName = userName usr 192 | domain = maybe "" (";domain="++) mdomain 193 | hmac = showDigest $ hmacSha1 (L8.pack key) (L8.pack uName) 194 | setCookie "_hails_user" $ show uName ++ domain 195 | setCookie "_hails_user_hmac" $ show hmac ++ domain 196 | 197 | -- | Get the username of the currently logged in user 198 | getCurrentUserOr :: Action t b IO () 199 | -> Action t b IO (Either (Action t b IO ()) String) 200 | getCurrentUserOr resp = do 201 | env <- liftIO getEnvironment 202 | case lookup "HMAC_KEY" env of 203 | Nothing -> return $ Left $ respondStat stat500 204 | Just key -> do 205 | req <- getHttpReq 206 | return $ maybe (Left resp) Right $ getAlreadyAuth req key 207 | 208 | -- | Check cookies for existing user 209 | getAlreadyAuth :: HttpReq t -> String -> Maybe String 210 | getAlreadyAuth req key = 211 | let cookies = reqCookies req 212 | in do user <- lookup "_hails_user" cookies 213 | mac0 <- lookup "_hails_user_hmac" cookies 214 | let mac1 = showDigest $ hmacSha1 (L8.pack key) (lazyfy user) 215 | if S8.unpack mac0 == mac1 216 | then return $ S8.unpack user 217 | else Nothing 218 | where lazyfy = L8.pack . S8.unpack 219 | 220 | 221 | -- | Get parameter or redirect back 222 | paramOrBack :: S -> (String -> Action t b IO ()) -> Action t b IO () 223 | paramOrBack n f = do 224 | mp <- param n 225 | maybe (redirectBack >> flashError "Incomplete form, try again.") 226 | (f . L8.unpack . paramValue) mp 227 | 228 | -------------------------------------------------------------------------------- /static/js/bootstrap.min.js: -------------------------------------------------------------------------------- 1 | /** 2 | * Bootstrap.js by @fat & @mdo 3 | * plugins: bootstrap-transition.js, bootstrap-modal.js, bootstrap-dropdown.js, bootstrap-scrollspy.js, bootstrap-tab.js, bootstrap-tooltip.js, bootstrap-popover.js, bootstrap-alert.js, bootstrap-button.js, bootstrap-collapse.js, bootstrap-carousel.js, bootstrap-typeahead.js 4 | * Copyright 2012 Twitter, Inc. 5 | * http://www.apache.org/licenses/LICENSE-2.0.txt 6 | */ 7 | !function(a){a(function(){a.support.transition=function(){var b=document.body||document.documentElement,c=b.style,d=c.transition!==undefined||c.WebkitTransition!==undefined||c.MozTransition!==undefined||c.MsTransition!==undefined||c.OTransition!==undefined;return d&&{end:function(){var b="TransitionEnd";return a.browser.webkit?b="webkitTransitionEnd":a.browser.mozilla?b="transitionend":a.browser.opera&&(b="oTransitionEnd"),b}()}}()})}(window.jQuery),!function(a){function c(){var b=this,c=setTimeout(function(){b.$element.off(a.support.transition.end),d.call(b)},500);this.$element.one(a.support.transition.end,function(){clearTimeout(c),d.call(b)})}function d(a){this.$element.hide().trigger("hidden"),e.call(this)}function e(b){var c=this,d=this.$element.hasClass("fade")?"fade":"";if(this.isShown&&this.options.backdrop){var e=a.support.transition&&d;this.$backdrop=a('