first commmit after cleanup and switching to stack

11 files changed, 498 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..76467e6
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.stack-work/
+*~
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..36f1718
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,5 @@
+# Changelog for staticus
+
+- First Release
+
+## Unreleased changes
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..e0b8508
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright Michal Idziorek <m.i@gmx.at> (c) 2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..a74efd1
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,12 @@
+run: build clean
+	stack run staticus-exe -- /home/miguel/git/staticus_www/INDEX /home/miguel/git/staticus_www/OUT
+build:
+	stack build
+clean:
+	-rm /home/miguel/git/staticus_www/OUT/* -r
+showdoc:
+	stack haddock
+#	firefox /home/miguel/git/staticus_www/staticus/.stack-work/install/x86_64-linux/lts-13.0/8.6.3/doc/index.html
+
+#hack to get css, copy this to a stanalone css file. file.md needs to have some source-code for pandoc
+#stack exec pandoc -- -s file.md --highlight-style pygments
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..c110d38
--- /dev/null
+++ b/README.md
@@ -0,0 +1,3 @@
+# staticus
+
+This is a simple static website generator coded in haskell by miguel
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..9727c8c
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,146 @@
+module Main where
+
+import WWWStaticus
+import WWWStaticusPlugins
+import System.Environment
+
+-- |The main IO action just feed the 2 command line parameters for
+-- input and output directories to WWWStaticus.runStaticus.
+main :: IO ()
+main = do args<-getArgs
+          prog<-getProgName
+          if length args /= 2
+          then putStrLn $ "usage: " ++ prog ++ " [in_path] [out_path]"
+          else runStaticus (args!!0) (args!!1) staticusPluginsDefault
+
+-- Only legacy stuff below this line --
+{-
+--import Data.List.Utils 
+--import Control.Monad.Reader 
+--import Text.Pandoc
+
+{-
+import Control.Exception
+import Control.Monad
+
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import qualified Data.Map as M
+import Data.Text(pack,unpack)
+import Data.Tree            
+
+import System.Directory     
+
+import Text.Regex
+-}
+-- TODO!!!
+replace seek replace txt = txt
+
+-- |'htmlLink' generates a HTML link from a href & title 
+htmlLink :: String -> String -> String -> String
+htmlLink href title cl="<a class= '"++cl++"' href='"++href++"'>"++replace "-" " " title++"</a>"
+
+-- generate HTML breadcrumbs from a list of page titles
+genBrc :: [String] -> String
+genBrc b | length b == 0 =  htmlCurrent "home"
+         | otherwise = htmlHome  ++ (fst $ foldl lnk ("",0) b)
+         where lnk (a,c) v | length b-c-1==0  = (a++htmlCurrent v,c+1)
+                           | otherwise = (a++htmlCrumb c v ,c+1)
+               htmlCrumb c v     = "<li class=\"breadcrumb-item\">"++(htmlLink (concat (replicate (length b-c-1) "../")) (v) "")++"</li>"
+               htmlCurrent v   = "<li class=\"breadcrumb-item active\" aria-current=\"page\">"++replace "-" " " v++"</li>"
+               htmlHome      = "<li class=\"breadcrumb-item\">"++(htmlLink "/" "home" "")++"</li>"
+
+-- pure function that generates a single HTML page from:
+-- a html template, description, keywords, breadcrumbs, topMenue & submenue
+genPage :: String->String->String->String->[String]->[String]->[String]->String->String
+genPage tmpl dsc kw ttl brc top chld md = 
+        foldr rplc tmpl (replacers content (menu "/" top) (menu "./" chld) (genBrc brc) title dsc kw)
+        where content = "content" -- either (const "error") unpack res
+                        where res = pack "content" -- runPure $ do doc <- readMarkdown def{readerExtensions=(enableExtension Ext_raw_html pandocExtensions )} $ pack md
+                                                   --writeHtml5String def doc
+              rplc v = replace ("##" ++ fst v ++ "##") (snd v)
+              title | null ttl  = if null brc then "Home" else replace "-" " " $ last brc
+                    | otherwise = ttl
+              menu p = foldr (fm p) "" 
+              fm p s a  | (not (null brc)) && (s == head brc) = "<li class=\"nav-item active\">"++htmlLink (p++s++"/") s "nav-link"++"</li>"++a
+                        | otherwise                           = "<li class=\"nav-item\">"++htmlLink (p++s++"/") s "nav-link"++"</li>"++a
+              replacers c m m2 b t d k= 
+                          [("CONTENT",        c)
+                          ,("LOGO",           "/DATA/logo.png")
+                          ,("STYLESHEET",     "/DATA/style.css")
+                          ,("SITE_TITLE",     "Miguel's Lair")
+                          ,("SITE_SUBTITLE",  "<br />where information sleepzzZZZzz ...")
+                          ,("TITLE",          t)
+                          ,("DESCRIPTION",    d)
+                          ,("KEYWORDS",       k)
+                          ,("AUTHOR",         "Michal Idziorek")
+                          ,("MENU",           m)
+                          ,("SUB_MENU",       m2)
+                          ,("BREADCRUMBS",    b)
+                          ,("FOOTER",         "(c) 1994-2018")]
+
+
+-- write the HTML page generated from current diectory by 'genPage'
+wrtPage2 :: FilePath -> FilePath -> String -> [FilePath] -> FilePath -> [FilePath] -> IO () 
+wrtPage2 idx out tmpl top p chld = do
+
+            when (not home) (createDirectory outdir)
+
+            mdd       <- readFile $ p ++ "/index.md"
+            md        <- customFiltersIO mdd
+            cfg       <- (map ((\(x:xs) -> (x,unwords xs)).words).lines) 
+                              <$> catch (readFile $ p++"/config") 
+                                  ((\_ -> return "") :: IOException -> IO String) 
+
+            writeFile (outdir++"/index.html") 
+                      (genPage tmpl (lkp cfg "dsc") (lkp cfg "kwd") (lkp cfg "ttl") 
+                               brc (menu top) (if home then [] else menu chld) (customFilters md))
+
+            where home       = outdir==out++"/"
+                  remUnder   = filter (not.null) . map (dropWhile(=='_').dropWhile(/='_'))
+                  lkp cfg k  = fromMaybe "" (lookup k cfg)
+                  menu       = remUnder . filter (not . isPrefixOf "00_") . map (last.splitOn "/") . sortBy (flip compare)
+                  outdir     = out ++ "/" ++  intercalate "/" brc
+                  brc        = remUnder $ splitOn "/" (drop (length idx) p)
+
+                                     
+
+
+-- TODO: plugins! --
+-- apply some customIO filters before passed to pandoc
+customFiltersIO :: String -> IO String
+customFiltersIO a = do let x = splitRegex (mkRegex "^\\{BEGIN:SOURCE\\}.*$|^\\{END:SOURCE\\}.*$") a
+                       concat <$> evr2 x
+                    where evr2 (x:y:xs) = do    putStrLn $ ">>"++y++"<<"
+                                                src  <- readFile $ replace "\n" "" y
+                                                rest <- evr2 xs
+                                                return $ x:src:rest
+                          evr2 x        = return x
+
+-- apply some custom filters before passed to pandoc
+customFilters :: String -> String
+customFilters a = concat $ evr2 $ splitRegex (mkRegex "^\\{BEGIN:CARD\\}$|^\\{END:CARD\\}$") a
+                where evr2 (x:y:xs) = x:createCard y:evr2 xs
+                      evr2 x        = x
+
+createCard:: String -> String
+createCard v  = let (_:x:y:z:_:xs)=lines v in replace "###IMG###" x 
+                                                 $ replace "###TITLE###" y
+                                                 $ replace "###FOOTER###" z -- (z++"<br />"++a)
+                                                 $ replace "###TEXT###" (unlines $ map spans xs) tmpl
+           where tmpl  ="<div class ='col-sm-6 col-md-4 col-xl-3 mb-4'>"
+                            ++"<div class='card h-100'>"
+                            ++"<img class='border-bottom card-img-top' src='###IMG###' >"
+                            ++"<div class='card-body'>"
+                            ++"<h5 class='card-title'>###TITLE###</h5>"
+                            ++"<p class='card-text'>"
+                            ++"###TEXT###"
+                            ++"</p>"
+                            ++"</div>"
+                            ++"<div class='text-center card-footer text-muted'>###FOOTER###</div>"
+                            ++"</div></div>"
+                 spans ('-':vv)=let (x:xs)=words vv in "<span class='badge "++x++"'>"++unwords xs++"</span>"
+                 spans xx = xx
+
+                 -}
diff --git a/src/WWWStaticus.hs b/src/WWWStaticus.hs
new file mode 100644
index 0000000..01485e4
--- /dev/null
+++ b/src/WWWStaticus.hs
@@ -0,0 +1,70 @@
+{-|
+    WWWStaticus is a minimalistic yet modular static website generator 
+    first coded in April 2018 by Michal Idziorek <m.i@gmx.at>.
+    Last Update: Jan 29, 2019
+-}
+
+module WWWStaticus
+    (  runStaticus
+      ,staticusPluginDummy
+      ,getDirList
+      ,StaticusPlugin(..)
+    ) where
+
+import qualified Data.Map.Strict as M
+import Data.Foldable
+import System.Directory
+import Control.Monad
+import Data.Tree
+import Data.Maybe
+
+-- |Runs WWWStaticus given an input and an output directory and a list of 
+-- plugins. This traverses 'inp' recursively and runs all the plugins 
+-- 'one by one' in each subdirectory recursively.
+runStaticus :: FilePath->FilePath->[StaticusPlugin]->IO()
+runStaticus inp outp plug= trvDirTree inp (runPlugins plug outp)
+
+-- |The following structure represents a single WWWStaticus plugin.
+-- A plugin is defined by a Name and two functions one pure and one that
+-- can do IO. The functions have to return a new map based on the input 
+-- map. Initially only "path" (current in path) and 
+-- "dir_in" (top directory) and "dir_out" are set. 
+-- "log" can be used for logging.
+data StaticusPlugin = 
+     StaticusPlugin  String 
+                     (M.Map String String->M.Map String String)
+                     (M.Map String String->IO (M.Map String String))
+
+-- |Example dummy plugin
+staticusPluginDummy = 
+    StaticusPlugin "Staticus Dummy Plugin" run runIO
+    where run   m = M.union 
+                        (M.fromList [("log",(fromJust$M.lookup "log" m)
+                                      ++"dummy was here!\n")]) m
+          runIO m = do
+                    print $ "I can do IO!"
+                    return m
+
+
+-- |sequence the IO Action 'f' for each subdirectory of 'fp' recursively.
+-- 'f' is passed 'fp' and the currently processed path as well.
+trvDirTree :: FilePath -> (FilePath ->FilePath->IO()) ->IO ()
+trvDirTree fp f = unfoldTreeM unf fp >>= sequence_
+                  where unf p = getDirList p >>= \s -> f fp p >>= \l -> 
+                                return (return l, s)
+
+-- |get list of subdirectories
+getDirList :: FilePath -> IO [FilePath]
+getDirList d = map ((d++"/")++) <$> listDirectory d
+               >>= filterM doesDirectoryExist
+
+-- |run plugins in a single directory 'path'. 
+-- 'dir_in' and 'dir_out' have to be provided as well, since plugins 
+-- might rely on this
+runPlugins::[StaticusPlugin]->FilePath->FilePath->FilePath->IO()
+runPlugins plug dir_out dir_in path = foldlM f init plug >> return ()
+                      where f m (StaticusPlugin name run runIO) = runIO m >>= return.run
+                            init= M.fromList [("path",path)
+                                             ,("dir_in",dir_in)
+                                             ,("dir_out",dir_out)
+                                             ,("log","run plugins at: "++path++"\n")]
diff --git a/src/WWWStaticusPlugins.hs b/src/WWWStaticusPlugins.hs
new file mode 100644
index 0000000..fe17583
--- /dev/null
+++ b/src/WWWStaticusPlugins.hs
@@ -0,0 +1,115 @@
+module WWWStaticusPlugins
+    ( staticusPluginsDefault
+     ,staticusPluginInit
+     ,staticusPluginCopy
+     ,staticusPluginPandoc
+     ,staticusPluginFill
+     ,staticusPluginWrite
+    ) where
+
+import WWWStaticus
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import System.Directory
+import Control.Monad
+import Data.Maybe
+import Data.Either
+import Data.List
+import Data.List.Split
+import Data.List.Utils
+import Text.Pandoc
+
+--
+-- TODOS: 
+--
+--       timestamp plugin/ do not refresh if md did not change? dir timestamp?
+--
+--       super `gallery and everythin` plugin, just throw images,videos,
+--       zips,tars,source files,mds etc inside a folder-> gen page!
+--
+--       flexible layout, main pic, secondary pics
+--
+--       scale images
+--
+--       asciinema, git, videos
+--
+--       contact form? (use nginx log? save post request??)
+--
+--       pdf plugin
+--       autotranslate plugin :P
+--
+
+-- |little helper to get values out of a map easily
+par k m = case M.lookup k m of
+            Just x -> x
+            Nothing -> error $ "key not found: "++k
+
+-- |A default set of plugins that you can use to kickstart your page
+-- Use now, Adapt later.
+staticusPluginsDefault::[StaticusPlugin]
+staticusPluginsDefault=[ staticusPluginInit
+                        ,staticusPluginCopy [".jpg",".png",".zip",".css",".js"]
+                        ,staticusPluginPandoc
+                        ,staticusPluginFill
+                        ,staticusPluginWrite
+                       ]
+
+-- |Creates target directory and sets basic params in map:
+-- outdir 
+staticusPluginInit::StaticusPlugin
+staticusPluginInit = StaticusPlugin "init" id runIO
+     where runIO m = 
+            do when (not isHome) (createDirectory outdir)
+               c    <- getDirList (par "path" m)
+               t    <- getDirList (par "dir_in" m)
+               let menutop= concat $ map (\x->"<li class=\"navitem\"><a class=\"nav-link\" href=\""++par "dir_out" m++"/"++x++"/index.html\">"++x++"</a></li>") (menu t)
+               let submenu= if isHome then "" else concat $ map (\x->"<li><a href=\""++outdir++"/"++x++"/index.html\">"++x++"</a></li>") (menu c)
+--             let breadcrumbs=concat brc
+               let breadcrumbs=""
+              --TODO: check top dirs until file found! add ./config
+               md   <- readFile $ par "path" m++"/"++"index.md"
+               tmpl <- readFile $ par "dir_in" m++"/"++"template.html"
+               return $ M.union (M.fromList [ ("outdir",outdir)
+                                             ,("index.md",md)
+                                             ,("template.html",tmpl)
+                                             ,("menutop",menutop)
+                                             ,("submenu",submenu)
+                                             ,("breadcrumbs",breadcrumbs)
+                                            ]) m
+            where outdir   = par "dir_out" m ++ "/" ++  intercalate "/" brc
+                  brc      = remUnder $ splitOn "/" (drop (length (par "dir_in" m)) (par "path" m))
+                  remUnder = filter (not.null) . map (dropWhile(=='_').dropWhile(/='_'))
+                  menu     = remUnder . filter (not . isPrefixOf "00_") . map (last.splitOn "/") . sortBy (flip compare)
+                  isHome   = par "path" m==par "dir_in" m
+
+-- |This plugin will simply copy files of given extension from source
+-- to the target directory. give it a list of extensions.
+staticusPluginCopy::[String]->StaticusPlugin
+staticusPluginCopy ext = StaticusPlugin "copy by extension" id runIO
+    where runIO m = do
+                    let tst x=or $ map ($x) (map isSuffixOf ext)
+                    dl <- filter tst <$> listDirectory (par "path" m)
+                    mapM_ (\x->copyFile (par "path" m++"/"++x) (par "outdir" m++"/"++x)) dl
+                    return m
+
+-- |pipes 'index.md' value through pandoc and saves in 'content'
+staticusPluginPandoc::StaticusPlugin
+staticusPluginPandoc = StaticusPlugin "pandoc" run return
+    where run m = let f = runPure $ do doc <- readMarkdown def{readerExtensions=(enableExtension Ext_raw_html pandocExtensions )} $ T.pack (par "index.md" m)
+                                       writeHtml5String def doc
+                  in M.union (M.fromList [("content",T.unpack (fromRight (T.pack "err") f))]) m
+
+-- |Plugin for filling the 'template.html' value with 'content'
+-- and storing in 'final'
+staticusPluginFill::StaticusPlugin
+staticusPluginFill = StaticusPlugin "fill template" run return
+    where run m = M.union (M.fromList [("final",
+                             replace "###BREADCRUMBS###" (par "breadcrumbs" m) $   replace "###SUBMENU###" (par "submenu" m) $  replace "###MENU###" (par "menutop" m) (replace "###CONTENT###" (par "content" m) (par "template.html" m)))]) m
+
+
+-- |write final index.html file
+staticusPluginWrite::StaticusPlugin
+staticusPluginWrite = StaticusPlugin "writer" id runIO
+    where runIO m = do
+                     writeFile ((par "outdir" m)++"/index.html") (par "final" m)
+                     return m
diff --git a/stack.yaml b/stack.yaml
new file mode 100644
index 0000000..1cc351e
--- /dev/null
+++ b/stack.yaml
@@ -0,0 +1,64 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-13.0
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.9"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
diff --git a/staticus.cabal b/staticus.cabal
new file mode 100644
index 0000000..e2145f6
--- /dev/null
+++ b/staticus.cabal
@@ -0,0 +1,49 @@
+cabal-version: 1.12
+
+name:           staticus
+version:        0.1.0.0
+description:    Check README.md
+author:         Michal Idziorek
+maintainer:     m.i@gmx.at
+copyright:      2019 Michal Idziorek
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+library
+  exposed-modules:
+      WWWStaticus
+      WWWStaticusPlugins
+  other-modules:
+      Paths_staticus
+  hs-source-dirs:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , containers
+    , split
+    , directory
+    , text
+    , pandoc
+    , MissingH
+  default-language: Haskell2010
+
+executable staticus-exe
+  main-is: Main.hs
+  other-modules:
+      Paths_staticus
+  hs-source-dirs:
+      app
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base >=4.7 && <5
+    , directory
+    , split
+    , text
+    , regex-compat
+    , containers
+    , staticus
+  default-language: Haskell2010