aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-26 12:42:30 +03:00
Code Issues Projects Releases Wiki Activity

Use config instead of environment variables

Browse Source
This commit is contained in:
Artyom 2016-03-22 01:17:53 +03:00
parent 9b778967a4
commit 72ad74a431
7 changed files with 191 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -21,3 +21,4 @@ TAGS
*~
*#
state/
config.json

8
INSTALL.md
View File

@ -5,7 +5,11 @@ The `state/` directory contains the database. You can download the current datab
$ git clone https://github.com/aelve/guide-database
$ mv guide-database state
If you want to enable tracking, replace the contents of `static/tracking.md` and set the environment variable `GUIDE_TRACKING=1` when running the server.
The `config.json` file contains the config (it will be created at the 1st start). There are 2 settings so far:
* `tracking-enabled` enables tracking. If you do enable it, don't forget to replace the contents of `static/tracking.md` with your own tracking script.
* `base-url` is the URL of the server (which should contain `http://` or `https://`). It's used for feed generation.
# How to install locally
@ -82,8 +86,6 @@ env LC_ALL=en_US.UTF-8
exec dist/build/guide/guide
~~~
If you want tracking, add `env GUIDE_TRACKING=1`. If you want e.g. feeds to work correctly, add `env GUIDE_URL="url of your instance here"` (and don't forget about `http://` or `https://`).
Start the daemon:
$ service guide start

8
README.md
View File

@ -3,16 +3,10 @@
[![Build status](https://secure.travis-ci.org/aelve/guide.svg)](https://travis-ci.org/aelve/guide)
[![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/aelve/guide/blob/master/LICENSE)
Installation instructions are here: [INSTALL.md](INSTALL.md).
Installation instructions and the explanation of config variables (in `config.json`) are here: [INSTALL.md](INSTALL.md).
The beta version is running at [guide.aelve.com](http://guide.aelve.com).
## Environment variables
* `GUIDE_TRACKING=1` enables tracking
* `GUIDE_URL="url of your instance here"` (and don't forget about `http://` or `https://`) is needed for some things (like feeds) to work correctly
## Contributing
If you want to contribute but don't know where to start, grep the source for

9
guide.cabal
View File

@ -29,6 +29,7 @@ source-repository head
executable guide
main-is: Main.hs
other-modules:
Config
Types
Utils
Markdown
@ -38,20 +39,26 @@ executable guide
build-depends: Spock
, Spock-lucid == 0.2.*
, acid-state == 0.14.*
, aeson == 0.11.*
, aeson-pretty == 0.7.*
, base >=4.8 && <4.9
, base-prelude
, blaze-builder
, bytestring
, cheapskate
, cheapskate-highlight == 0.1.*
, cheapskate-lucid == 0.1.*
, containers >= 0.5
, data-default >= 0.5
, directory >= 1.2
, ekg
, ekg-core
, feed >= 0.3.11 && < 0.4
, filepath
, lucid
, lucid >= 2.9.5 && < 3
, megaparsec
, microlens-platform >= 0.2.3
, mmorph == 1.*
, mtl
, neat-interpolation == 0.3.*
, path-pieces

73
src/Config.hs Normal file
View File

@ -0,0 +1,73 @@
{-# LANGUAGE
OverloadedStrings,
RecordWildCards,
NoImplicitPrelude
#-}
module Config
(
Config(..),
readConfig,
modifyConfig,
)
where
-- General
import BasePrelude
-- JSON
import Data.Aeson as Aeson
import Data.Aeson.Encode.Pretty as Aeson hiding (Config)
-- ByteString
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
-- Files
import System.Directory
-- Default
import Data.Default
-- Local
import Utils
data Config = Config {
_trackingEnabled :: Bool,
_baseUrl :: Url }
deriving (Eq, Show)
instance Default Config where
def = Config {
_trackingEnabled = False,
_baseUrl = "/" }
instance FromJSON Config where
parseJSON = withObject "config" $ \o -> do
_trackingEnabled <- o .:? "tracking-enabled" .!= _trackingEnabled def
_baseUrl <- o .:? "base-url" .!= _baseUrl def
return Config{..}
instance ToJSON Config where
toJSON Config{..} = object [
"tracking-enabled" .= _trackingEnabled,
"base-url" .= _baseUrl ]
readConfig :: IO Config
readConfig = do
let filename = "config.json"
exists <- doesFileExist filename
when (not exists) $ do
putStrLn "config.json doesn't exist, creating it"
BSL.writeFile filename (Aeson.encodePretty (def :: Config))
contents <- BSL.fromStrict <$> BS.readFile filename
case Aeson.eitherDecode' contents of
Left err -> error ("error when reading config: " ++ err)
Right cfg -> return cfg
modifyConfig :: (Config -> IO Config) -> IO ()
modifyConfig func = do
file <- readConfig
-- Create-and-rename is safer than just rewriting the file
let newFile = "config-new.json"
BSL.writeFile newFile . Aeson.encodePretty =<< func file
renameFile newFile "config.json"

67
src/Main.hs
View File

@ -4,6 +4,7 @@ ScopedTypeVariables,
TypeFamilies,
DataKinds,
MultiWayIf,
FlexibleContexts,
NoImplicitPrelude
#-}
@ -15,6 +16,8 @@ module Main (main) where
import BasePrelude hiding (Category)
-- Monads and monad transformers
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Morph
-- Lenses
import Lens.Micro.Platform hiding ((&))
-- Containers
@ -49,8 +52,9 @@ import Data.Acid as Acid
import Data.Time
-- Local
import View
import Config
import Types
import View
import JS (JS(..), allJSFunctions)
import Markdown
import Utils
@ -62,20 +66,32 @@ import Utils
type DB = AcidState GlobalState
dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ DB,
dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
EventState event ~ GlobalState, UpdateEvent event)
=> event -> m (EventResult event)
dbUpdate x = do
db <- Spock.getState
db <- _db <$> Spock.getState
liftIO $ Acid.update db x
dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ DB,
dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
EventState event ~ GlobalState, QueryEvent event)
=> event -> m (EventResult event)
dbQuery x = do
db <- Spock.getState
db <- _db <$> Spock.getState
liftIO $ Acid.query db x
------------------------------------------------------------------------------
-- Server state
------------------------------------------------------------------------------
data ServerState = ServerState {
_config :: Config,
_db :: DB }
getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState)
=> m Config
getConfig = _config <$> Spock.getState
itemVar :: Path '[Uid]
itemVar = "item" <//> var
@ -85,7 +101,7 @@ categoryVar = "category" <//> var
traitVar :: Path '[Uid]
traitVar = "trait" <//> var
renderMethods :: SpockM () () DB ()
renderMethods :: SpockM () () ServerState ()
renderMethods = Spock.subcomponent "render" $ do
-- Title of a category
Spock.get (categoryVar <//> "title") $ \catId -> do
@ -123,7 +139,7 @@ renderMethods = Spock.subcomponent "render" $ do
-- TODO: [easy] use window.onerror to catch and show all JS errors (showing
-- could be done by displaying an alert)
setMethods :: SpockM () () DB ()
setMethods :: SpockM () () ServerState ()
setMethods = Spock.subcomponent "set" $ do
-- Title of a category
Spock.post (categoryVar <//> "title") $ \catId -> do
@ -192,7 +208,7 @@ setMethods = Spock.subcomponent "set" $ do
-- TODO: [easy] add stuff like “add/category” here in comments to make it
-- easier to search with C-s (or maybe just don't use subcomponent?)
addMethods :: SpockM () () DB ()
addMethods :: SpockM () () ServerState ()
addMethods = Spock.subcomponent "add" $ do
-- New category
Spock.post "category" $ do
@ -228,7 +244,7 @@ addMethods = Spock.subcomponent "add" $ do
newTrait <- dbUpdate (AddCon itemId traitId content')
lucidIO $ renderTrait itemId newTrait
otherMethods :: SpockM () () DB ()
otherMethods :: SpockM () () ServerState ()
otherMethods = do
-- Moving things
Spock.subcomponent "move" $ do
@ -252,7 +268,7 @@ otherMethods = do
-- Feeds
-- TODO: this link shouldn't be absolute [absolute-links]
baseUrl <- (</> "haskell") . fromMaybe "/" <$> liftIO (lookupEnv "GUIDE_URL")
baseUrl <- (</> "haskell") . T.unpack . _baseUrl <$> getConfig
Spock.subcomponent "feed" $ do
-- Feed for items in a category
Spock.get categoryVar $ \catId -> do
@ -286,8 +302,19 @@ itemToFeedEntry baseUrl category item =
(Atom.TextString (T.unpack (item^.name)))
(Feed.toFeedDateStringUTC Feed.AtomKind (item^.created))
-- TODO: rename GlobalState to DB, and DB to AcidDB
lucidWithConfig
:: (MonadIO m, HasSpock (ActionCtxT cxt m),
SpockState (ActionCtxT cxt m) ~ ServerState)
=> HtmlT (ReaderT Config IO) a -> ActionCtxT cxt m a
lucidWithConfig x = do
cfg <- getConfig
lucidIO (hoist (flip runReaderT cfg) x)
main :: IO ()
main = do
config <- readConfig
let emptyState = GlobalState mempty
-- When we run in GHCi and we exit the main thread, the EKG thread (that
-- runs the localhost:5050 server which provides statistics) may keep
@ -329,9 +356,12 @@ main = do
EKG.Gauge.set textGauge (fromIntegral textLength)
threadDelay (1000000 * 60)
-- Run the server
let config = (defaultSpockCfg () PCNoDatabase db) {
let serverState = ServerState {
_config = config,
_db = db }
let spockConfig = (defaultSpockCfg () PCNoDatabase serverState) {
spc_maxRequestSize = Just (1024*1024) }
runSpock 8080 $ spock config $ do
runSpock 8080 $ spock spockConfig $ do
middleware (EKG.metrics waiMetrics)
middleware (staticPolicy (addBase "static"))
-- Javascript
@ -345,7 +375,8 @@ main = do
-- (css.css is a static file and so isn't handled here)
-- Main page
Spock.get root $ lucidIO $ do
Spock.get root $
lucidWithConfig $ do
head_ $ do
title_ "Aelve Guide"
includeCSS "/css.css"
@ -355,19 +386,19 @@ main = do
h2_ (a_ [href_ "/haskell"] "Haskell")
-- Donation page
Spock.get "donate" $ do
lucidIO $ renderDonate
Spock.get "donate" $
lucidWithConfig $ renderDonate
-- Unwritten rules
Spock.get "unwritten-rules" $ do
lucidIO $ renderUnwrittenRules
lucidWithConfig $ renderUnwrittenRules
-- Haskell
Spock.subcomponent "haskell" $ do
Spock.get root $ do
s <- dbQuery GetGlobalState
q <- param "q"
lucidIO $ renderRoot s q
lucidWithConfig $ renderRoot s q
-- Category pages
Spock.get var $ \path -> do
-- The links look like /parsers-gao238b1 (because it's nice when
@ -384,7 +415,7 @@ main = do
when (categorySlug category /= path) $
-- TODO: this link shouldn't be absolute [absolute-links]
Spock.redirect ("/haskell/" <> categorySlug category)
lucidIO $ renderCategoryPage category
lucidWithConfig $ renderCategoryPage category
-- The add/set methods return rendered parts of the structure (added
-- categories, changed items, etc) so that the Javascript part could
-- take them and inject into the page. We don't want to duplicate

78
src/View.hs
View File

@ -51,6 +51,7 @@ import BasePrelude hiding (Category)
import Lens.Micro.Platform hiding ((&))
-- Monads and monad transformers
import Control.Monad.IO.Class
import Control.Monad.Reader
-- Containers
import qualified Data.Map as M
-- Text
@ -62,6 +63,7 @@ import NeatInterpolation
import Lucid hiding (for_)
-- Local
import Config
import Types
import Utils
import JS (JS(..), JQuerySelector)
@ -93,7 +95,9 @@ instead of simple
-}
renderRoot :: GlobalState -> Maybe Text -> HtmlT IO ()
renderRoot
:: (MonadIO m, MonadReader Config m)
=> GlobalState -> Maybe Text -> HtmlT m ()
renderRoot globalState mbSearchQuery =
wrapPage "Aelve Guide" $ do
-- TODO: [very-easy] this header looks bad when the page is narrow, it
@ -136,9 +140,9 @@ renderRoot globalState mbSearchQuery =
-- TODO: when submitting a text field, gray it out (but leave it selectable)
-- until it's been submitted
renderTracking :: HtmlT IO ()
renderTracking :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderTracking = do
trackingEnabled <- (== Just "1") <$> liftIO (lookupEnv "GUIDE_TRACKING")
trackingEnabled <- lift (asks _trackingEnabled)
when trackingEnabled $ do
tracking <- liftIO $ T.readFile "static/tracking.html"
toHtmlRaw tracking
@ -146,7 +150,7 @@ renderTracking = do
-- TODO: include jQuery locally so that it'd be possible to test the site
-- without internet
renderDonate :: HtmlT IO ()
renderDonate :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderDonate = doctypehtml_ $ do
head_ $ do
title_ "Donate to Artyom"
@ -155,13 +159,17 @@ renderDonate = doctypehtml_ $ do
body_ $
toHtmlRaw =<< liftIO (readFile "static/donate.html")
renderUnwrittenRules :: HtmlT IO ()
renderUnwrittenRules :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderUnwrittenRules = wrapPage "Unwritten rules" $ do
toHtml . renderMarkdownBlock =<<
liftIO (T.readFile "static/unwritten-rules.md")
-- Include all the necessary things
wrapPage :: Text -> HtmlT IO () -> HtmlT IO ()
wrapPage
:: (MonadIO m, MonadReader Config m)
=> Text -- ^ Page title
-> HtmlT m ()
-> HtmlT m ()
wrapPage pageTitle page = doctypehtml_ $ do
head_ $ do
title_ (toHtml pageTitle)
@ -204,7 +212,8 @@ wrapPage pageTitle page = doctypehtml_ $ do
a_ [href_ "/donate"] "donate"
sup_ [style_ "font-size:50%"] "I don't have a job"
renderCategoryPage :: Category -> HtmlT IO ()
renderCategoryPage
:: (MonadIO m, MonadReader Config m) => Category -> HtmlT m ()
renderCategoryPage category =
wrapPage (category^.title <> " – Aelve Guide") $ do
-- TODO: [very-easy] this header looks bad when the page is narrow, it
@ -226,7 +235,7 @@ renderCategoryPage category =
-- TODO: add a list for “interesting libraries, but too lazy to describe, so
-- somebody describe them for me”
renderHelp :: HtmlT IO ()
renderHelp :: (MonadIO m, MonadReader Config m) => HtmlT m ()
renderHelp = do
div_ [id_ "help"] $ do
@ -266,12 +275,12 @@ helpVersion = 3
-- TODO: automatic merge should be possible too (e.g. if the changes are in
-- different paragraphs)
renderCategoryList :: [Category] -> HtmlT IO ()
renderCategoryList :: MonadIO m => [Category] -> HtmlT m ()
renderCategoryList cats =
div_ [id_ "categories"] $
mapM_ renderCategory cats
renderCategoryTitle :: Category -> HtmlT IO ()
renderCategoryTitle :: Monad m => Category -> HtmlT m ()
renderCategoryTitle category = do
let thisId = "category-title-" <> uidToText (category^.uid)
this = JS.selectId thisId
@ -294,7 +303,7 @@ renderCategoryTitle category = do
textButton "cancel" $
JS.switchSection (this, "normal" :: Text)
renderCategoryNotes :: Category -> HtmlT IO ()
renderCategoryNotes :: MonadIO m => Category -> HtmlT m ()
renderCategoryNotes category = do
let thisId = "category-notes-" <> uidToText (category^.uid)
this = JS.selectId thisId
@ -314,7 +323,7 @@ renderCategoryNotes category = do
(\val -> JS.submitCategoryNotes (this, category^.uid, val))
(JS.switchSection (this, "normal" :: Text))
renderCategory :: Category -> HtmlT IO ()
renderCategory :: MonadIO m => Category -> HtmlT m ()
renderCategory category =
div_ [class_ "category", uid_ (category^.uid)] $ do
renderCategoryTitle category
@ -335,7 +344,7 @@ getItemHue category item = case item^.group_ of
-- TODO: perhaps use jQuery Touch Punch or something to allow dragging items
-- instead of using arrows? Touch Punch works on mobile, too
renderItem :: Category -> Item -> HtmlT IO ()
renderItem :: MonadIO m => Category -> Item -> HtmlT m ()
renderItem category item =
-- The id is used for links in feeds, and for anchor links
div_ [id_ ("item-" <> uidToText (item^.uid)), class_ "item"] $ do
@ -387,7 +396,7 @@ renderItemTitle item = do
Nothing -> toHtml (item^.name)
-- TODO: give a link to oldest available docs when the new docs aren't there
renderItemInfo :: Category -> Item -> HtmlT IO ()
renderItemInfo :: MonadIO m => Category -> Item -> HtmlT m ()
renderItemInfo cat item = do
let bg = hueToDarkColor $ getItemHue cat item
let thisId = "item-info-" <> uidToText (item^.uid)
@ -498,7 +507,7 @@ renderItemInfo cat item = do
-- TODO: categories without items (e.g. “web dev”) that list links to other
-- categories
renderItemDescription :: Item -> HtmlT IO ()
renderItemDescription :: MonadIO m => Item -> HtmlT m ()
renderItemDescription item = do
let thisId = "item-description-" <> uidToText (item^.uid)
this = JS.selectId thisId
@ -518,7 +527,7 @@ renderItemDescription item = do
(\val -> JS.submitItemDescription (this, item^.uid, val))
(JS.switchSection (this, "normal" :: Text))
renderItemEcosystem :: Item -> HtmlT IO ()
renderItemEcosystem :: MonadIO m => Item -> HtmlT m ()
renderItemEcosystem item = do
let thisId = "item-ecosystem-" <> uidToText (item^.uid)
this = JS.selectId thisId
@ -540,7 +549,9 @@ renderItemEcosystem item = do
(\val -> JS.submitItemEcosystem (this, item^.uid, val))
(JS.switchSection (this, "normal" :: Text))
renderItemTraits :: Item -> HtmlT IO ()
-- TODO: change MonadIO to MonadRandom mostly everywhere
renderItemTraits :: MonadIO m => Item -> HtmlT m ()
renderItemTraits item = do
div_ [class_ "item-traits"] $ do
this <- thisNode
@ -580,7 +591,7 @@ renderItemTraits item = do
textButton "edit off" $
JS.switchSectionsEverywhere(this, "normal" :: Text)
renderTrait :: Uid -> Trait -> HtmlT IO ()
renderTrait :: MonadIO m => Uid -> Trait -> HtmlT m ()
renderTrait itemId trait = do
let thisId = "trait-" <> uidToText (trait^.uid)
this = JS.selectId thisId
@ -636,7 +647,7 @@ renderTrait itemId trait = do
-- TODO: [very-easy] focus the notes textarea on edit (can use jQuery's
-- .focus() on it)
renderItemNotes :: Item -> HtmlT IO ()
renderItemNotes :: MonadIO m => Item -> HtmlT m ()
renderItemNotes item = do
let thisId = "item-notes-" <> uidToText (item^.uid)
this = JS.selectId thisId
@ -679,7 +690,7 @@ renderItemNotes item = do
-- TODO: a shortcut for editing (when you press Ctrl-something, whatever was
-- selected becomes editable)
renderItemForFeed :: Item -> Html ()
renderItemForFeed :: Monad m => Item -> HtmlT m ()
renderItemForFeed item = do
h1_ $ renderItemTitle item
when (item^.description /= "") $
@ -697,10 +708,10 @@ renderItemForFeed item = do
-- Utils
onPageLoad :: JS -> HtmlT IO ()
onPageLoad :: Monad m => JS -> HtmlT m ()
onPageLoad js = script_ $ format "$(document).ready(function(){{}});" [js]
emptySpan :: Text -> HtmlT IO ()
emptySpan :: Monad m => Text -> HtmlT m ()
emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty
-- Use inputValue to get the value (works with input_ and textarea_)
@ -708,7 +719,7 @@ onEnter :: JS -> Attribute
onEnter handler = onkeydown_ $
format "if (event.keyCode == 13) {{} return false;}" [handler]
textInput :: [Attribute] -> HtmlT IO ()
textInput :: Monad m => [Attribute] -> HtmlT m ()
textInput attrs = input_ (type_ "text" : attrs)
inputValue :: JS
@ -720,7 +731,7 @@ clearInput = JS "this.value = '';"
onFormSubmit :: (JS -> JS) -> Attribute
onFormSubmit f = onsubmit_ $ format "{} return false;" [f (JS "this")]
button :: Text -> [Attribute] -> JS -> HtmlT IO ()
button :: Monad m => Text -> [Attribute] -> JS -> HtmlT m ()
button value attrs handler =
input_ (type_ "button" : value_ value : onclick_ handler' : attrs)
where
@ -730,9 +741,10 @@ button value attrs handler =
--
-- TODO: consider dotted links instead?
textButton
:: Text -- ^ Button text
:: Monad m
=> Text -- ^ Button text
-> JS -- ^ Onclick handler
-> HtmlT IO ()
-> HtmlT m ()
textButton caption (JS handler) =
span_ [class_ "text-button"] $
-- “#” is used instead of javascript:void(0) because the latter is slow
@ -741,17 +753,18 @@ textButton caption (JS handler) =
(toHtml caption)
-- So far all icons used here have been from <https://useiconic.com/open/>
imgButton :: Text -> Url -> [Attribute] -> JS -> HtmlT IO ()
imgButton :: Monad m => Text -> Url -> [Attribute] -> JS -> HtmlT m ()
imgButton alt src attrs (JS handler) =
a_ [href_ "#", onclick_ (handler <> "return false;")]
(img_ (src_ src : alt_ alt : attrs))
markdownEditor
:: [Attribute]
:: MonadIO m
=> [Attribute]
-> MarkdownBlock -- ^ Default text
-> (JS -> JS) -- ^ “Submit” handler, receiving the contents of the editor
-> JS -- ^ “Cancel” handler
-> HtmlT IO ()
-> HtmlT m ()
markdownEditor attr (markdownBlockText -> s) submit cancel = do
textareaId <- randomLongUid
-- Autocomplete has to be turned off thanks to
@ -770,11 +783,12 @@ markdownEditor attr (markdownBlockText -> s) submit cancel = do
"Markdown"
smallMarkdownEditor
:: [Attribute]
:: MonadIO m
=> [Attribute]
-> MarkdownInline -- ^ Default text
-> (JS -> JS) -- ^ “Submit” handler, receiving the contents of the editor
-> Maybe JS -- ^ “Cancel” handler (if “Cancel” is needed)
-> HtmlT IO ()
-> HtmlT m ()
smallMarkdownEditor attr (markdownInlineText -> s) submit mbCancel = do
textareaId <- randomLongUid
let val = JS $ format "document.getElementById(\"{}\").value" [textareaId]
@ -789,7 +803,7 @@ smallMarkdownEditor attr (markdownInlineText -> s) submit mbCancel = do
JS.assign val s <>
cancel
thisNode :: HtmlT IO JQuerySelector
thisNode :: MonadIO m => HtmlT m JQuerySelector
thisNode = do
uid' <- randomLongUid
-- If the class name ever changes, fix 'JS.moveNodeUp' and