work

4 files changed, 128 insertions, 36 deletions

diff --git a/hs/Html.hs b/hs/Html.hs
index a28efa5..0e5b0fe 100644
--- a/hs/Html.hs
+++ b/hs/Html.hs
@@ -7,7 +7,7 @@ module Html
 ( main
 ) where
 
-import System.Environment (getArgs)
+import System.Environment (getArgs, lookupEnv)
 import System.FilePath
     ( joinPath
     , takeDirectory
@@ -18,6 +18,7 @@ import System.FilePath
     , dropExtension
     , takeBaseName
     )
+import System.Directory (copyFile)
 
 import Text.Pandoc
     ( PandocMonad
@@ -50,11 +51,14 @@ import Text.Pandoc.Writers.Shared
     , lookupMetaString
     )
 
+import System.IO (readFile')
 import Data.Text (Text, unpack, pack)
 import Data.Text.IO qualified as T
 import Data.Text.Lazy (toStrict)
-import Network.URI (parseURI, uriPath, uriScheme, uriFragment, uriQuery, URI)
+--import Network.URI --(parseURI, uriPath, uriScheme, uriFragment, uriQuery, uriAuthority, URI, URIAuth)
+import Network.URI hiding (query)
 import Data.Maybe (listToMaybe, fromMaybe)
+import Data.List (partition)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -110,7 +114,7 @@ vimwikiToHTML txt = do
     return $ toStrict . renderHtml $ html
 -}
 
-data Configuration = Configuration 
+data Configuration = Configuration
     { inputDir :: FilePath
     , outputDir :: FilePath
     -- Are we in a subdirectory from the web root?
@@ -120,7 +124,7 @@ data Configuration = Configuration
     , mu4eURL :: Text
     -- http://wiki.gandalf.adrift.space/search
     , xapianOmega :: Text
-    }
+    } deriving (Read, Show)
 
 type UrlRewriter = [Inline] -> URI -> ([Inline], Text)
 
@@ -131,7 +135,7 @@ mailRewriter conf body uri = (body, (mu4eURL conf) <> "?id=" <> (pack $ uriPath
 -- https://gist.github.com/rixx/6cb5fa38f694009ad0bd50c275bb61f2
 
 archMan :: (Semigroup a, IsString a) => a -> Maybe a -> Maybe a -> a
-archMan page section' language' 
+archMan page section' language'
     = "https://man.archlinux.org/man/" <> page <> f section' <> f language'
     where f = fromMaybe "" . fmap ("." <>)
 
@@ -141,10 +145,10 @@ mannedMan page section' language'
     where f = fromMaybe "" . fmap ("." <>)
 
 manRewriter :: UrlRewriter
-manRewriter _ uri 
+manRewriter _ uri
     = ([Str $ path <> "(" <> (fromMaybe "?" section') <> ")"]
       , mannedMan path section' language')
-    where path :: Text 
+    where path :: Text
           path = pack $ uriPath uri
           section'  = pack . tail <$> nullToMaybe (uriFragment uri)
           language' = pack . tail <$> nullToMaybe (uriQuery uri)
@@ -162,12 +166,29 @@ fixExtension url
     | hasExtension url = url
     | otherwise = url <.> "html"
 
+
+-- TODO make this part of the configuration
+resolveInterwiki :: String -> URI -> String
+resolveInterwiki wikiname uri =
+    case wikiname of
+        "public"  -> show $ uri { uriScheme = "http:", uriAuthority = Just $ URIAuth "" "//wiki.gandalf.adrift.space" "", uriPath = "/" <> uriPath uri <> ".html" }
+        "private" -> show $ uri { uriScheme = "http:", uriAuthority = Just $ URIAuth "" "//wiki.gandalf.adrift.space" "", uriPath = "/private/" <> uriPath uri <> ".html" }
+        _         -> error $ "Unknown Wiki name: '" <> wikiname <> "'"
+
+
+
 rebuildLinks :: Configuration -> Inline -> Inline
 rebuildLinks conf l@(Link attributes body (url, title@"wikilink"))
     = case parseURI . unpack $ url of
-        Just uri -> case M.lookup (init . uriScheme $ uri) (urlRewrites conf) of
-                        Just proc -> (proc body uri) & (\(body, url) -> Link attributes body (url, title))
-                        Nothing   -> l -- Link attributes body (url <> ".html", title)
+        Just uri -> case uriScheme uri of
+                        ('w':'n':'.':wikiname') -> let wikiname = init wikiname'
+                                                   in Link attributes
+                                                       [ Str . pack . uriPath $ uri
+                                                       , Superscript [Str $ pack wikiname]]
+                                                       (pack $ resolveInterwiki wikiname uri, title)
+                        _ -> case M.lookup (init . uriScheme $ uri) (urlRewrites conf) of
+                                Just proc -> (proc body uri) & (\(body, url) -> Link attributes body (url, title))
+                                Nothing   -> l -- Link attributes body (url <> ".html", title)
         Nothing -> case break (== '#') (unpack url) of
                 ("", '#':_)       -> Link attributes body (url, title)
                 (page, "")        -> Link attributes body (pack $ fixExtension page, title)
@@ -179,7 +200,7 @@ rebuildLinks _ l = l
 -- Link ("",[],[]) [Str "https://styrdokument.liu.se/Regelsamling/Fil/1513619"] ("https://styrdokument.liu.se/Regelsamling/Fil/1513619","")
 -- Link ("",[],[]) [Str "Beslut",Space,Str "LIU-2020-02033"] ("file:LinTek/2021/Beslut om riktlinjer och rutiner f\246r genomf\246rande av skriftliga salsskrivningar inklusive digitala tent.pdf","wikilink")
 
-checkbox extra = RawInline (Format "html") 
+checkbox extra = RawInline (Format "html")
                $ "<input type='checkbox' disabled='true' " <> extra <> "/>"
 
 -- buildCheckboxes s@(Span (ids, cls, kvs) _)
@@ -192,7 +213,7 @@ buildCheckboxes s@(Span (_, cls, _) _)
     | otherwise = s
 buildCheckboxes l = l
 
-buildCheckboxes' (Plain (Str "[-]" : Space : xs)) 
+buildCheckboxes' (Plain (Str "[-]" : Space : xs))
     = Plain [ checkbox "checked", Strikeout xs ]
 buildCheckboxes' l = l
 
@@ -242,7 +263,6 @@ breadcrumbLinks conf parts = f <$> (accumulate $ (unpack $ webPath conf) : parts
     where f parts = joinBy "/" parts -<.> "html"
 
 buildBreadcrumbs :: [String] -> [Html]
--- TODO replace leading string with wiki root
 buildBreadcrumbs links = f <$> links
     where f :: String -> Html
           f link = H.a ! href (textValue . pack $ link)
@@ -256,13 +276,13 @@ htmlWrap conf title parts backlinks toc main = docTypeHtml $ do
     H.meta ! name "generator" ! content "pandoc"
     H.meta ! name "viewport" ! content "width=device-width, initial-scale=1.0, user-scalable=yes"
     H.link ! rel "stylesheet" ! (href . textValue $ webPath conf <> "/style.css")
+    H.script ! (A.src . textValue $ (webPath conf <> "/script.js")) $ mempty
     H.title $ H.string $ title <> " — Vimwiki"
   H.body $ do
     H.header $ do
         H.nav ! A.id "breadcrumb" $ do
             let bc = (buildBreadcrumbs . breadcrumbLinks conf $ init parts)
-            -- TODO replace /tmp/wiki with wiki-base
-            let all = mconcat [ [ H.a ! (href . textValue $ webPath conf <> "/index.html") 
+            let all = mconcat [ [ H.a ! (href . textValue $ webPath conf <> "/index.html")
                                       $ "⌂" ]
                               , tail bc
                               , [ H.span $ H.string . takeBaseName . last $ parts ] ]
@@ -273,10 +293,14 @@ htmlWrap conf title parts backlinks toc main = docTypeHtml $ do
                    $ do
                      H.input ! A.type_ "search" ! A.name "P" ! A.placeholder "Sök..."
                      H.input ! A.type_ "submit" ! A.value "Sök"
-    H.nav ! A.id "TOC" ! role "doc-toc" $ do
-      H.h2 ! A.id "toc-title" $ "Table of Contents"
-      toc
-    H.main $ main
+    H.div ! A.id "with-resizer" $ do
+        H.main $ main
+        H.div ! A.id "resizer" $ do
+            H.div ! A.id "resize-handle" $ "<>"
+        H.nav ! A.id "TOC" ! role "doc-toc" $ do
+          H.div $ do
+              H.h2 ! A.id "toc-title" $ "Table of Contents"
+              toc
     H.footer $ do
         backlinks
 
@@ -318,7 +342,7 @@ handlePart conf outdir backlinks wiki_root parts = do
     -- before and after, and check if it is langer
     -- log <- getsCommonState stLog
     -- liftIO $ print meta
-    let title :: Text = firstJust (pack $ takeBaseName item_path) 
+    let title :: Text = firstJust (pack $ takeBaseName item_path)
                           [ nullToMaybe $ lookupMetaString "title" meta
                           , headerContent =<< (listToMaybe $ allHeaders pandoc)
                           ]
@@ -334,21 +358,23 @@ main = do
     (indir, outdir) <- case args of
         [indir, outdir] -> return (indir, outdir)
         _ -> error "Usage: vimwiki <indir> <outdir>"
-    -- let wiki_root = "/home/hugo/wiki/private"
-    -- wiki_files :: [(FileStatus, [FilePath])]
-    wiki_files <- filter (uncurry isWikiFile) <$> fileTree [ indir ]
+    (wiki_files, other_files) <- partition (uncurry isWikiFile) <$> fileTree [ indir ]
     -- TODO copy remaining files verbatim
     -- st <- getFileStatus $ indir </> "Vimwiki.wiki"
     -- wiki_files <- return $ [(st, snoc [ indir ] "Vimwiki.wiki")]
     let relative_paths = tail . snd <$> wiki_files
 
-    let conf = Configuration { inputDir = indir
-                             , outputDir = outdir
-                             -- , webPath = "/tmp/wiki"
-                             , webPath = ""
-                             , mu4eURL = "http://localhost:8090"
-                             , xapianOmega = "http://wiki.gandalf.adrift.space/search"
-                             }
+    webPath <- pack . fromMaybe "" <$> lookupEnv "WEB_PATH"
+
+    conf' <- (read :: String -> Configuration) <$> readFile' "config.hs"
+    let conf = conf' { inputDir = indir
+                     , outputDir = outdir
+                     -- , webPath = "/tmp/wiki"
+                     , webPath = webPath
+                     }
+
+    copyFile "style2.css" (outputDir conf <> "/style.css")
+    copyFile "script.js" (outputDir conf <> "/script.js")
 
     -- What each page links to
     -- forwardLinks :: [(FilePath, [String])]
diff --git a/hs/config.hs b/hs/config.hs
new file mode 100644
index 0000000..eee62e5
--- /dev/null
+++ b/hs/config.hs
@@ -0,0 +1,5 @@
+Configuration 
+{ mu4eURL = "http://localhost:8090"
+, xapianOmega = "http://wiki.gandalf.adrift.space/search"
+}
+
diff --git a/hs/script.js b/hs/script.js
new file mode 100644
index 0000000..b1f5f20
--- /dev/null
+++ b/hs/script.js
@@ -0,0 +1,16 @@
+window.onload = () => {
+	let resizer = document.getElementById('resizer')
+	let root = null
+	let dx = 0;
+	resizer.addEventListener('mousedown', (event) => {
+		root = event.clientX + dx
+	})
+	window.addEventListener('mouseup', (event) => {
+		root = null
+	})
+	window.addEventListener('mousemove', (event) => {
+		if (! root) return
+		dx = root - event.clientX
+		document.documentElement.style.setProperty('--toc-width', `${dx}px`)
+	})
+}
diff --git a/hs/style2.css b/hs/style2.css
index e6e3378..4038c87 100644
--- a/hs/style2.css
+++ b/hs/style2.css
@@ -1,19 +1,64 @@
+:root {
+	--toc-width: 0px;
+}
+
 body {
+	/*
 	display: grid;
-	/* grid-template-columns: auto 1fr */
-	grid-template-columns: 1fr auto;
+	grid-template-columns: 1fr auto auto;
+	*/
 }
 
 img {
 	max-width: 100%;
 }
 
+main {
+	flex-grow: 1;
+}
+
+#with-resizer {
+	display: flex;
+	flex-direction: row;
+	overflow-x: clip;
+}
+
+#resizer {
+	min-width: 1ex;
+	background-color: lightgray;
+	cursor: col-resize;
+}
+
+#resize-handle {
+  display: block;
+  background-color: lightblue;
+  padding: 1em;
+    padding-right: 1em;
+    padding-left: 1em;
+  position: fixed;
+  top: 50%;
+  margin-left: -0.8em;
+  padding-left: 0.5em;
+  padding-right: 0.5em;
+  font-family: mono;
+  border-radius: 1ex;
+  user-select: none;
+}
+
 /* Table of contents */
 #TOC {
-	grid-column: 2;
+	grid-column: 3;
 	grid-row: 2;
 	white-space: nowrap;
-	max-width: 15em;
+	width: calc(15em + var(--toc-width));
+}
+
+#TOC h2 {
+	text-align: center;
+}
+
+#TOC > div {
+	position: fixed;
 }
 
 #TOC ul {
@@ -29,7 +74,7 @@ img {
 
 header {
 	grid-row: 1;
-	grid-column: 1/3;
+	grid-column: 1/4;
 	display: flex;
 	flex-direction: row;
 	justify-content: space-between;
@@ -46,7 +91,7 @@ header {
 main {
 	grid-column: 1;
 	grid-row: 2;
-	max-width: 60ch;
+	/* max-width: 60ch; */
 }
 
 main table {