first

blog-meta/lib/Misc.hs

@@ -0,0 +1,22 @@
+module Misc where
+
+import qualified System.Console.GetOpt as GetOpt
+import System.Environment
+import System.Exit
+
+-- | exception on 'Left'
+unwrap :: Show a => FilePath -> Either a b -> IO b
+unwrap file = either (\x -> fail $ file <> ":" <> show x) return
+
+getOptionsWith :: (String -> String) -> ([String] -> Maybe a)
+               -> [GetOpt.OptDescr (a -> a)] -> IO a
+getOptionsWith hdr mkDef descrs = do
+  res <- GetOpt.getOpt GetOpt.Permute descrs <$> getArgs
+  case res of
+    (fs, rest, []) | Just def <- mkDef rest ->
+      return $ foldl (flip ($)) def fs
+    _ -> do
+      prog <- getProgName
+      putStrLn $ GetOpt.usageInfo (hdr prog) descrs
+      exitFailure
+

blog-meta/lib/YAML.hs

@@ -0,0 +1,52 @@
+module YAML (module YAML) where
+
+import Data.YAML as YAML
+import Data.YAML.Event as YAML (untagged)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Misc
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LazyBS
+import qualified System.IO as IO
+
+
+str' :: String -> Node ()
+str' = str . Text.pack
+
+str :: Text -> Node ()
+str = Scalar () . SStr
+
+obj :: Mapping () -> Node ()
+obj = Mapping () untagged
+
+(##=) :: (ToYAML b) => Text -> b -> (Node (), Node ())
+(##=) = (#=)
+
+(#=) :: (ToYAML a, ToYAML b) => a -> b -> (Node (), Node ())
+k #= v = (toYAML k, toYAML v)
+
+list :: ToYAML a => [a] -> Node ()
+list = Sequence () untagged . map toYAML
+
+
+-- | read a chunk from the beginning of the file between a
+-- @---@ and a @...@. throw an exception if there isn't one
+readHeader :: FilePath -> IO (YAML.Node YAML.Pos)
+readHeader file = IO.withFile file IO.ReadMode \h -> do
+  ln <- BS.hGetLine h
+  if (ln /= "---") then
+    fail $ file <> ": no header"
+  else
+    unwrap file . YAML.decode1 =<< linesUntil "..." h
+
+-- | read all the lines from a handle until the given terminator. return the
+-- lines read, excluding the terminator
+linesUntil :: ByteString -> IO.Handle -> IO LazyBS.ByteString
+linesUntil end h = go [] where
+  go acc = do
+    l <- BS.hGetLine h
+    if l == end then
+      return $ LazyBS.fromChunks $ reverse acc
+    else
+      go (l <> "\n" : acc)