fix some Haskell scripts

nixos/roles/git.nix

@@ -10,7 +10,6 @@
     name = "post-update";
     bins = [pkgs.git pkgs.laminar];
     imports = [
-      "System.Environment (lookupEnv)"
       "System.Directory (withCurrentDirectory)"
     ];
   } ''

nixos/roles/laminar/bump-config.hs

@@ -1,9 +1,11 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE ExtendedDefaultRules #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -Wall -Werror -Wno-missing-signatures -Wno-type-defaults -Wno-orphans #-}
 
@@ -19,7 +21,10 @@ import System.Environment
 load Absolute ["git", "niv"]
 paths :: [Text]
 paths =
-  $$(liftTyped . mapMaybe (\x -> foldr (<|>) Nothing $ (\bin -> Text.stripSuffix [i|/#{bin}|] $ toText x) <$> ["git", "tar", "nix-prefetch-url", "gzip"]) =<< runIO pathBinsAbs)
+  $$( bindCode (runIO pathBinsAbs) \rawPaths ->
+        let wantedPaths :: [Text] = mapMaybe (\x -> foldr (<|>) Nothing $ (\bin -> Text.stripSuffix [i|/#{bin}|] $ toText x) <$> ["git", "tar", "nix-prefetch-url", "gzip"]) rawPaths
+         in liftTyped wantedPaths
+    )
 
 repo = "git@hera.m-0.eu:nixos-config"
 

nixos/roles/laminar/test-config.hs

@@ -18,7 +18,7 @@ import Language.Haskell.TH.Syntax
 import Relude
 import Say
 import Shh
-import System.Environment
+import System.Environment (getEnv, setEnv)
 
 load Absolute ["laminarc", "git", "nix-build"]
 
@@ -26,21 +26,21 @@ repo = "git@hera.m-0.eu:nixos-config"
 
 jobs :: [String]
 jobs =
-  $$( liftTyped
-        =<< runIO
-          ( do
-              homes <- getEnv "HOMES"
-              systems <- getEnv "SYSTEMS"
-              let ret =
-                    ((\x -> [i|system-config-#{x}|]) <$> (words . toText) systems)
-                      <> ((\x -> [i|home-config-#{x}|]) <$> (words . toText) homes)
-              say [i|Found jobs #{ret}|]
-              pure ret
-          )
+  $$( bindCode
+        ( runIO $ do
+            homes <- getEnv "HOMES"
+            systems <- getEnv "SYSTEMS"
+            let ret =
+                  ((\x -> [i|system-config-#{x}|]) <$> (words . toText) systems)
+                    <> ((\x -> [i|home-config-#{x}|]) <$> (words . toText) homes)
+            say [i|Found jobs #{ret}|]
+            pure ret
+        )
+        liftTyped
     )
 
 deployCommand :: String
-deployCommand = $$(liftTyped =<< runIO (getEnv "DEPLOY"))
+deployCommand = $$(bindCode (runIO $ getEnv "DEPLOY") liftTyped)
 
 main = do
   let process = fromMaybe "main" . (stripPrefix "refs/heads/" . toText =<<)

nixos/roles/matrix-synapse/synapse-cleanup.hs

@@ -42,10 +42,10 @@ import Network.HTTP (
 import Relude
 import Say (say, sayErr)
 import Shh (ExecReference (Absolute), load, (|>))
-import System.IO (BufferMode (LineBuffering), hSetBuffering)
+import System.IO (BufferMode (LineBuffering))
 
 -- Executables used.
-load Absolute ["synapse-compress-state", "cat", "psql", "rm"]
+load Absolute ["synapse_compress_state", "cat", "psql", "rm"]
 
 newtype PurgeResult = PurgeResult {purge_id :: Text} deriving (Generic, FromJSON)
 newtype Status = Status {status :: Text} deriving (Generic, FromJSON)
@@ -127,7 +127,7 @@ processRoom :: Text -> PSQL.Connection -> UTCTime -> Text -> IO ()
 processRoom token conn upToTime roomId = do
   whenJustM (queryLastKeptEvent conn roomId) (purgeUpToEvent token roomId upToTime)
   say [i|Compressing state in room #{roomId} ...|]
-  synapse_compress_state "-o" filename "-p" "host=/run/postgresql user=matrix-synapse dbname=matrix-synapse" "-r" (toString roomId)
+  synapse'_compress'_state "-o" filename "-p" "host=/run/postgresql user=matrix-synapse dbname=matrix-synapse" "-r" (toString roomId)
   cat filename |> psql "matrix-synapse"
   rm filename