-- |  Helper functions and types that can be useful
--    in more than one place.
module LiBro.Util
  (
  -- * Tree building
    ParentList
  , readForest
  -- * Counting monad transformer
  , CountingT
  , next
  , runCountingT
  -- * XLSX as data backend
  , storeAsXlsx
  , loadFromXlsx
  -- * Shady LibreOffice handling
  , libreOfficeIsRunning
  , spawnLibreOffice
  , killLibreOffice
  -- * Other helper functions
  , guarded
  ) where

import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Tuple
import Data.List as L
import qualified Data.Map as M
import qualified Data.HashMap.Lazy as HM
import qualified Data.Vector as V
import Data.Tree
import Data.Maybe
import Data.Csv
import Data.Bifunctor
import GHC.Utils.Monad
import Control.Monad
import Control.Monad.State
import Control.Applicative
import Control.Exception
import System.FilePath
import System.Directory
import System.IO.Temp
import System.Process
import System.Exit

-- |  A 'Tree'/'Forest' representation as a linear list.
--    All entries point to their parent.
type ParentList a = [(a, Maybe a)]

-- |  Reads a forest from a given 'ParentList', sorting each 'Node's children.
readForest :: Ord a => ParentList a -> Forest a
readForest :: forall a. Ord a => ParentList a -> Forest a
readForest ParentList a
pairs =
  let (ParentList a
rs, ParentList a
is)  = ((a, Maybe a) -> Bool)
-> ParentList a -> (ParentList a, ParentList a)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe a -> Bool)
-> ((a, Maybe a) -> Maybe a) -> (a, Maybe a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Maybe a) -> Maybe a
forall a b. (a, b) -> b
snd) ParentList a
pairs
      roots :: [a]
roots     = (a, Maybe a) -> a
forall a b. (a, b) -> a
fst ((a, Maybe a) -> a) -> ParentList a -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParentList a
rs
      inners :: [(a, a)]
inners    = (Maybe a -> a) -> (a, Maybe a) -> (a, a)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust ((a, Maybe a) -> (a, a)) -> ParentList a -> [(a, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParentList a
is
      children :: Map a [a]
children  = ([a] -> [a] -> [a]) -> [(a, [a])] -> Map a [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(a, [a])] -> Map a [a]) -> [(a, [a])] -> Map a [a]
forall a b. (a -> b) -> a -> b
$ ((a, a) -> (a, [a])) -> [(a, a)] -> [(a, [a])]
forall a b. (a -> b) -> [a] -> [b]
L.map ((a -> [a]) -> (a, a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) ((a, a) -> (a, [a])) -> ((a, a) -> (a, a)) -> (a, a) -> (a, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, a) -> (a, a)
forall a b. (a, b) -> (b, a)
swap) [(a, a)]
inners
  in  Map a [a] -> a -> Tree a
forall {a}. Ord a => Map a [a] -> a -> Tree a
fill Map a [a]
children (a -> Tree a) -> [a] -> [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
roots
  where fill :: Map a [a] -> a -> Tree a
fill Map a [a]
cs a
n = a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Node a
n ([Tree a] -> Tree a) -> [Tree a] -> Tree a
forall a b. (a -> b) -> a -> b
$ case a -> Map a [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
n Map a [a]
cs of
                              Maybe [a]
Nothing -> []; Just [] -> []
                              Just [a]
xs -> Map a [a] -> a -> Tree a
fill Map a [a]
cs (a -> Tree a) -> [a] -> [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
xs

-- |  Simple monad transformer that allows to read an increasing 'Int'.
type CountingT m = StateT Int m

-- |  Grabs the next 'Int'.
next :: Monad m => CountingT m Int
next :: forall (m :: * -> *). Monad m => CountingT m Int
next = do
  Int
val <- CountingT m Int
forall s (m :: * -> *). MonadState s m => m s
get
  (Int -> Int) -> StateT Int m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify Int -> Int
forall a. Enum a => a -> a
succ
  Int -> CountingT m Int
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
val

-- |  Evaluate the given action with counting from the given initial value.
runCountingT :: Monad m => CountingT m a -> Int -> m a
runCountingT :: forall (m :: * -> *) a. Monad m => CountingT m a -> Int -> m a
runCountingT = StateT Int m a -> Int -> m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT

-- |  Create an 'Alternative' value based on a predicate.
guarded :: Alternative f => (a -> Bool) -> a -> f a
guarded :: forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarded a -> Bool
p a
x = if a -> Bool
p a
x then a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x else f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
empty

--  Internal newtype wrapper to mask special cell values
--  like references ("=foo") by prepending '%'
newtype Wrap a = Wrap {forall a. Wrap a -> a
unWrap :: a} deriving Int -> Wrap a -> ShowS
[Wrap a] -> ShowS
Wrap a -> String
(Int -> Wrap a -> ShowS)
-> (Wrap a -> String) -> ([Wrap a] -> ShowS) -> Show (Wrap a)
forall a. Show a => Int -> Wrap a -> ShowS
forall a. Show a => [Wrap a] -> ShowS
forall a. Show a => Wrap a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Wrap a -> ShowS
showsPrec :: Int -> Wrap a -> ShowS
$cshow :: forall a. Show a => Wrap a -> String
show :: Wrap a -> String
$cshowList :: forall a. Show a => [Wrap a] -> ShowS
showList :: [Wrap a] -> ShowS
Show
instance ToNamedRecord a => ToNamedRecord (Wrap a) where
  toNamedRecord :: Wrap a -> NamedRecord
toNamedRecord = NamedRecord -> NamedRecord
post (NamedRecord -> NamedRecord)
-> (Wrap a -> NamedRecord) -> Wrap a -> NamedRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NamedRecord
forall a. ToNamedRecord a => a -> NamedRecord
toNamedRecord (a -> NamedRecord) -> (Wrap a -> a) -> Wrap a -> NamedRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrap a -> a
forall a. Wrap a -> a
unWrap
    where post :: NamedRecord -> NamedRecord
post  = [(ByteString, ByteString)] -> NamedRecord
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(ByteString, ByteString)] -> NamedRecord)
-> (NamedRecord -> [(ByteString, ByteString)])
-> NamedRecord
-> NamedRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString -> ByteString)
-> (ByteString, ByteString)
-> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> ByteString
wrap ByteString -> ByteString
wrap) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> (NamedRecord -> [(ByteString, ByteString)])
-> NamedRecord
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedRecord -> [(ByteString, ByteString)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
          wrap :: ByteString -> ByteString
wrap  = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
'%' (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8Lenient
instance FromNamedRecord a => FromNamedRecord (Wrap a) where
  parseNamedRecord :: NamedRecord -> Parser (Wrap a)
parseNamedRecord  = (a -> Wrap a) -> Parser a -> Parser (Wrap a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Wrap a
forall a. a -> Wrap a
Wrap (Parser a -> Parser (Wrap a))
-> (NamedRecord -> Parser a) -> NamedRecord -> Parser (Wrap a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedRecord -> Parser a
forall a. FromNamedRecord a => NamedRecord -> Parser a
parseNamedRecord (NamedRecord -> Parser a)
-> (NamedRecord -> NamedRecord) -> NamedRecord -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedRecord -> NamedRecord
pre
    where pre :: NamedRecord -> NamedRecord
pre       = [(ByteString, ByteString)] -> NamedRecord
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(ByteString, ByteString)] -> NamedRecord)
-> (NamedRecord -> [(ByteString, ByteString)])
-> NamedRecord
-> NamedRecord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> (ByteString, ByteString))
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map ((ByteString -> ByteString)
-> (ByteString -> ByteString)
-> (ByteString, ByteString)
-> (ByteString, ByteString)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> ByteString
unwrap ByteString -> ByteString
unwrap) ([(ByteString, ByteString)] -> [(ByteString, ByteString)])
-> (NamedRecord -> [(ByteString, ByteString)])
-> NamedRecord
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedRecord -> [(ByteString, ByteString)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
          unwrap :: ByteString -> ByteString
unwrap    = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text
Text -> Text
T.tail (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8Lenient
instance DefaultOrdered a => DefaultOrdered (Wrap a) where
  headerOrder :: Wrap a -> Header
headerOrder   = (ByteString -> ByteString) -> Header -> Header
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
wrap (Header -> Header) -> (Wrap a -> Header) -> Wrap a -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Header
forall a. DefaultOrdered a => a -> Header
headerOrder (a -> Header) -> (Wrap a -> a) -> Wrap a -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wrap a -> a
forall a. Wrap a -> a
unWrap
    where wrap :: ByteString -> ByteString
wrap  = Text -> ByteString
TE.encodeUtf8 (Text -> ByteString)
-> (ByteString -> Text) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text -> Text
T.cons Char
'%' (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8Lenient

-- |  Store a list of (CSV-transformable) data to a XLSX file.
--    CAVEAT: round-trips don't work with unsafe text values.
--    Use "LiBro.Data.SafeText".
storeAsXlsx :: (DefaultOrdered a, ToNamedRecord a) => FilePath -> [a] -> IO ()
storeAsXlsx :: forall a.
(DefaultOrdered a, ToNamedRecord a) =>
String -> [a] -> IO ()
storeAsXlsx String
fp [a]
records = do
  String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"xlsx-export" ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
tdir -> do
    let csvFile :: String
csvFile = String
tdir String -> ShowS
</> String
"export.csv"
    String -> ByteString -> IO ()
LBS.writeFile String
csvFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [Wrap a] -> ByteString
forall a. (DefaultOrdered a, ToNamedRecord a) => [a] -> ByteString
encodeDefaultOrderedByName (a -> Wrap a
forall a. a -> Wrap a
Wrap (a -> Wrap a) -> [a] -> [Wrap a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
records)
    String -> IO ()
callCommand (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
      [ String
"libreoffice --calc --convert-to xlsx"
      , String
"--outdir", String
tdir, String
csvFile
      , String
"> /dev/null"
      ]
    String -> String -> IO ()
renameFile (String
csvFile String -> ShowS
-<.> String
"xlsx") String
fp

-- |  Load a list of (CSV-transformable) data from a XLSX file.
--    CAVEAT: round-trips don't work with unsafe text values.
--    Use "LiBro.Data.SafeText".
loadFromXlsx :: FromNamedRecord a => FilePath -> IO (Either String [a])
loadFromXlsx :: forall a. FromNamedRecord a => String -> IO (Either String [a])
loadFromXlsx String
fp = do
  String
-> (String -> IO (Either String [a])) -> IO (Either String [a])
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
String -> (String -> m a) -> m a
withSystemTempDirectory String
"xlsx-import" ((String -> IO (Either String [a])) -> IO (Either String [a]))
-> (String -> IO (Either String [a])) -> IO (Either String [a])
forall a b. (a -> b) -> a -> b
$ \String
tdir -> do
    let xlsxFile :: String
xlsxFile = String
tdir String -> ShowS
</> String
"import.xlsx"
    String -> String -> IO ()
copyFile String
fp String
xlsxFile
    String -> IO ()
callCommand (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
      [ String
"libreoffice"
      , String
"--calc"
      , String
"--convert-to csv" -- implies headless
      , String
"--outdir", String
tdir
      , String
xlsxFile
      , String
"> /dev/null"
      ]
    ByteString
csv <- String -> IO ByteString
LBS.readFile (String
xlsxFile String -> ShowS
-<.> String
"csv")
    Either String [a] -> IO (Either String [a])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String [a] -> IO (Either String [a]))
-> Either String [a] -> IO (Either String [a])
forall a b. (a -> b) -> a -> b
$ (Wrap a -> a) -> [Wrap a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Wrap a -> a
forall a. Wrap a -> a
unWrap ([Wrap a] -> [a])
-> ((Header, Vector (Wrap a)) -> [Wrap a])
-> (Header, Vector (Wrap a))
-> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Wrap a) -> [Wrap a]
forall a. Vector a -> [a]
V.toList (Vector (Wrap a) -> [Wrap a])
-> ((Header, Vector (Wrap a)) -> Vector (Wrap a))
-> (Header, Vector (Wrap a))
-> [Wrap a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header, Vector (Wrap a)) -> Vector (Wrap a)
forall a b. (a, b) -> b
snd ((Header, Vector (Wrap a)) -> [a])
-> Either String (Header, Vector (Wrap a)) -> Either String [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String (Header, Vector (Wrap a))
forall a.
FromNamedRecord a =>
ByteString -> Either String (Header, Vector a)
decodeByName ByteString
csv

libreOfficeProcessNames :: [String]
libreOfficeProcessNames :: [String]
libreOfficeProcessNames = String -> [String]
words String
"libreoffice oosplash soffice.bin"

-- |  Tries to report if a LibreOffice instance is already running
libreOfficeIsRunning :: IO Bool
libreOfficeIsRunning :: IO Bool
libreOfficeIsRunning = ((String -> IO Bool) -> [String] -> IO Bool
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
(a -> m Bool) -> f a -> m Bool
`anyM` [String]
libreOfficeProcessNames) ((String -> IO Bool) -> IO Bool) -> (String -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
name -> do
  (ExitCode
_, String
output, String
_) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"pgrep" [String
name] String
""
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not(Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
output

-- |  Starts LibreOffice in the background.
--    This is useful to speed up conversion.
spawnLibreOffice :: IO ()
spawnLibreOffice :: IO ()
spawnLibreOffice = do
  IO ()
cleanupLibreOffice
  IO ProcessHandle -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ProcessHandle -> IO ()) -> IO ProcessHandle -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ProcessHandle
spawnCommand String
command
  where command :: String
command = [String] -> String
unwords
                    [ String
"libreoffice"
                    , String
"--calc"
                    , String
"--headless"
                    , String
"--norestore"
                    , String
"--view"
                    , String
dummy
                    , String
"> /dev/null"
                    ]
        dummy :: String
dummy   = String
"libreoffice-files/empty.ods"

-- |  Kills LibreOffice with SIGKILL, if it is actually running.
--    See 'libreOfficeIsRunning'.
killLibreOffice :: IO ()
killLibreOffice :: IO ()
killLibreOffice = do
  IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM IO Bool
libreOfficeIsRunning (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ()
ignoreExitCode (String -> IO ()
callCommand String
killCommand)
    IO ()
cleanupLibreOffice
  where killCommand :: String
killCommand       = String
"kill -9 $(pidof "
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
libreOfficeProcessNames
                              String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        ignoreExitCode :: IO () -> IO ()
ignoreExitCode IO ()
a  = IO () -> (ExitCode -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
a (IO () -> ExitCode -> IO ()
forall a b. a -> b -> a
const (IO () -> ExitCode -> IO ()) -> IO () -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () :: ExitCode -> IO ())

cleanupLibreOffice :: IO ()
cleanupLibreOffice :: IO ()
cleanupLibreOffice = String -> IO ()
callCommand String
"rm -f libreoffice-files/.~lock.empty.ods#"