@@ -0,0 +1,116 @@
1+{-# LANGUAGE TypeApplications #-}
2+{-# LANGUAGE PatternGuards #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+module Obelisk.Configs.Internal.Environment where
6+
7+import Control.Applicative
8+import Control.Monad
9+import qualified Data.Attoparsec.ByteString as P
10+import qualified Data.Attoparsec.ByteString.Char8 as P (hexadecimal)
11+import qualified Data.Attoparsec.Combinator as P
12+import Data.Bifunctor (second)
13+import Data.ByteString (ByteString)
14+import qualified Data.ByteString as BS
15+import qualified Data.ByteString.Base64 as Base64
16+import qualified Data.ByteString.Builder as Builder
17+import qualified Data.ByteString.Char8 as Char8
18+import qualified Data.ByteString.Lazy as LBS
19+import qualified Data.Char as Char
20+import Data.Map (Map)
21+import qualified Data.Map as Map
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+import qualified Data.Text.Lazy as LT
25+import Data.Tuple (swap)
26+import Data.Witherable
27+import Data.Word
28+import System.Environment
29+import qualified Text.Printf as Printf
30+
31+
32+data EnvCodec
33+ = EnvCodec_Char8
34+ | EnvCodec_Base64
35+ deriving (Eq, Ord, Show)
36+
37+envVarEscapes :: [(Char, Word8)]
38+envVarEscapes = fmap (second f)
39+ [ ('-', 'h')
40+ , ('_', 'u')
41+ , ('.', 'd')
42+ ]
43+ where
44+ f :: Char -> Word8
45+ f = fromIntegral . Char.ord
46+
47+escapeVarName :: EnvCodec -> Text -> ByteString
48+escapeVarName codec x = LBS.toStrict . Builder.toLazyByteString $ T.foldr ((<>) . f) mempty x <> codec'
49+ where
50+ escapeCode = Map.fromList envVarEscapes
51+
52+ codec' = case codec of
53+ EnvCodec_Base64 -> "__base64"
54+ EnvCodec_Char8 -> ""
55+
56+ f :: Char -> Builder.Builder
57+ f c
58+ | not (Char.isAscii c) = error "bad"
59+ | c == '/' = "_"
60+ | Char.isAlphaNum c = Builder.char7 c
61+ | Just c' <- Map.lookup c escapeCode = "__" <> Builder.word8 c'
62+ | otherwise = "__x" <> (Builder.string7 $ Printf.formatInt (Char.ord c) (Printf.FieldFormat (Just 2) Nothing (Just Printf.ZeroPad) Nothing False "" 'x') "")
63+
64+unescapeVarName :: ByteString -> Either String (Text, EnvCodec)
65+unescapeVarName x = P.parseOnly ((,) <$> fileName <*> codec <* P.endOfInput) x
66+ where
67+ escapeCode = Map.fromList $ fmap swap envVarEscapes
68+
69+ codec :: P.Parser EnvCodec
70+ codec = P.option EnvCodec_Char8 $ (EnvCodec_Base64 <$ "__base64")
71+
72+ -- | parse ps. succeed only if both ps and qs succeeds
73+ guardLookahead ps qs = do
74+ p <- ps
75+ _ <- P.lookAhead qs
76+ return p
77+
78+ parseEscapeCode =
79+ ("__" *> (do
80+ c <- P.anyWord8
81+ case Map.lookup c escapeCode of
82+ Nothing -> mzero
83+ Just c' -> return c')
84+ ) <|> ( "__x" *> (Char.chr . fromIntegral <$> P.hexadecimal @Word8))
85+
86+ parseEnvChar = Char.chr . fromIntegral <$> P.satisfy (P.inClass "a-zA-Z0-9")
87+
88+ fileName = LT.toStrict . LT.pack <$> P.many' (P.choice
89+ [ parseEnvChar
90+ , parseEscapeCode
91+ , guardLookahead ('/' <$ "_") (parseEnvChar <|> parseEscapeCode)
92+ ])
93+
94+
95+getConfigsFromEnvironment :: ByteString -> Map Text ByteString -> IO (Map Text ByteString)
96+getConfigsFromEnvironment varNamePrefix dirConfigs = do
97+ let
98+ prefix needle haystack
99+ | needle `BS.isPrefixOf` haystack = Just (BS.drop (BS.length needle) haystack)
100+ | otherwise = Nothing
101+
102+ makeEnv (k0, v0) = case prefix varNamePrefix (Char8.pack k0) of
103+ Nothing -> return Nothing
104+ Just k -> case unescapeVarName k of
105+ Left bad -> error bad
106+ Right (k', codec) ->
107+ let
108+ v = case codec of
109+ EnvCodec_Char8 -> Char8.pack v0
110+ EnvCodec_Base64 -> Base64.decodeLenient (Char8.pack v0)
111+ in case Map.lookup k' dirConfigs of
112+ Just v' | v /= v' -> error $ "conflicting obelisk config: env " <> k0 <> " /= ./config/" <> (T.unpack k')
113+ _ -> return (Just (k', v))
114+
115+ env <- wither makeEnv =<< getEnvironment
116+ return $ (Map.fromList env) <> dirConfigs