1-- SPDX-FileCopyrightText: 2020 Serokell <https://serokell.io/>
2--
3-- SPDX-License-Identifier: MPL-2.0
4
5{-# LANGUAGE CPP #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE TypeApplications #-}
9
10#include <HsBaseConfig.h>
11
12module Main (main) where
13
14import Prelude hiding (print, putStr, putStrLn)
15
16import Control.Exception.Safe (catchIO, tryIO)
17import Control.Monad (filterM, forM_, when)
18import Data.List (sort)
19import Data.Maybe (isJust)
20import Data.Version (showVersion)
21import Foreign.C.String (CString, peekCAString)
22import GHC.IO.Encoding (getLocaleEncoding, initLocaleEncoding)
23#if !(defined(mingw32_HOST_OS) || defined(__MINGW32__))
24import GHC.IO.Encoding.Iconv (localeEncodingName)
25#endif
26import GHC.Show (showLitString)
27import Language.Haskell.TH.Env (envQ)
28import System.Directory (doesDirectoryExist, doesPathExist, listDirectory)
29import System.Environment (lookupEnv)
30import System.FilePath ((</>))
31import System.Info (arch, compilerName, compilerVersion, os)
32import System.IO (hGetEncoding, stderr, stdout)
33import System.Process (readProcess)
34
35
36#if MIN_VERSION_base(4,11,0)
37#else
38import Data.Semigroup ((<>))
39#endif
40
41import qualified Prelude as P
42
43
44-- | Encode a 'String' to be safe to print in ASCII-only.
45protect :: String -> String
46protect s = showLitString s ""
47
48
49putStr :: String -> IO ()
50putStr = P.putStr . protect
51
52putStrLn :: String -> IO ()
53putStrLn = P.putStrLn . protect
54
55showEnvVar :: String -> IO ()
56showEnvVar name = do
57  putStr $ "  * " <> name <> " "
58  lookupEnv name >>= \case
59    Nothing -> putStrLn "is not set"
60    Just v -> putStrLn $ "= " <> v
61
62
63showSystem :: IO ()
64showSystem = do
65    putStrLn "# System"
66    putStrLn $ "  * OS = " <> os
67    putStrLn $ "  * arch = " <> arch
68    putStrLn $ "  * compiler = "
69            <> compilerName <> " " <> showVersion compilerVersion
70    showEnvVar "TERM"
71
72    -- Nix stuff
73    let builtNix = isJust ($$(envQ @String "NIX_BUILD_TOP"))
74    when builtNix $ do
75      putStrLn "  * Built with Nix"
76    let builtNixShell = isJust ($$(envQ @String "IN_NIX_SHELL"))
77    when builtNixShell $ do
78      putStrLn "  * Built in nix-shell"
79    inNixShell <- isJust <$> lookupEnv "IN_NIX_SHELL"
80    when inNixShell $ do
81      putStrLn "  * Running in nix-shell"
82
83    when (builtNix || builtNixShell) $ do
84      showEnvVar "LOCALE_ARCHIVE"
85
86
87showGhc :: IO ()
88showGhc = do
89    putStrLn "# GHC"
90    putStrLn $ "  * initLocaleEncoding = " <> show initLocaleEncoding
91    getLocaleEncoding >>= \e -> putStrLn $ "  * locale encoding = " <> show e
92    hGetEncoding stdout >>= \e -> putStrLn $ "  * stdout = " <> show e
93    hGetEncoding stderr >>= \e -> putStrLn $ "  * stderr = " <> show e
94
95showCbits :: IO ()
96showCbits = do
97    putStrLn "# C bits"
98#if !(defined(mingw32_HOST_OS) || defined(__MINGW32__))
99    putStrLn $ "  * localeEncodingName = " <> localeEncodingName
100#endif
101    showLibcharset
102    showLanginfoh
103  where
104    showLibcharset :: IO ()
105    showLibcharset = do
106#if defined(HAVE_LIBCHARSET)
107      enc <- c_libcharsetEncoding >>= peekCAString
108      putStrLn $ "  * libcharset:locale_charset = " <> enc
109#else
110      putStrLn $ "  * No libcharset."
111#endif
112
113    showLanginfoh :: IO ()
114    showLanginfoh = do
115#if defined(HAVE_LANGINFO_H)
116      enc <- c_langinfoEncoding >>= peekCAString
117      putStrLn $ "  * langinfo.h:nl_langinfo(CODESET) = " <> enc
118#else
119      putStrLn $ "  * No <langinfo.h>."
120#endif
121
122#if defined(HAVE_LIBCHARSET)
123foreign import ccall unsafe "libcharsetEncoding"
124  c_libcharsetEncoding :: IO CString
125#endif
126
127#if defined(HAVE_LANGINFO_H)
128foreign import ccall unsafe "langinfoEncoding"
129  c_langinfoEncoding :: IO CString
130#endif
131
132showEnv :: IO ()
133showEnv = do
134    putStrLn "# Environment"
135    mapM_ showEnvVar
136      [ "LANG"
137      , "LC_CTYPE"
138      , "LC_ALL="
139      ]
140
141showLocales :: IO ()
142showLocales = do
143    putStrLn "# Locales"
144    tryIO callLocalectl >>= \case
145      Right out -> do
146        putStrLn $ "  * localectl list-locales:"
147        showLocaleList (lines out)
148      Left _ -> do
149        listDir "/usr/lib/locale"
150        listFile "/usr/lib/locale/locale-archive" `catchIO` \e ->
151          putStrLn $ "<error>: " <> show e
152  where
153    showLocaleList :: [String] -> IO ()
154    showLocaleList locales =
155      forM_ (sort locales) $ \item -> putStrLn $ "    * " <> item
156
157    callLocalectl :: IO String
158    callLocalectl = readProcess "localectl" ["list-locales"] ""
159
160    listDir :: FilePath -> IO ()
161    listDir path = doesPathExist path >>= \case
162      False -> putStrLn $ "  * " <> path <> " does not exist"
163      True -> doesDirectoryExist path >>= \case
164        False -> putStrLn $ "  * " <> path <> " is not a directory"
165        True -> do
166          putStrLn $ "  * " <> path <> ":"
167          ls <- listDirectory path >>= filterM (doesDirectoryExist . (path </>))
168          showLocaleList ls
169
170    listFile :: FilePath -> IO ()
171    listFile path = doesPathExist path >>= \case
172      False -> putStrLn $ "  * " <> path <> " does not exist"
173      True -> do
174        putStrLn $ "  * " <> path <> ":"
175        out <- readProcess "localedef" ["--list", path] ""
176        showLocaleList (lines out)
177
178
179
180main :: IO ()
181main = do
182  showSystem
183  showGhc
184  showCbits
185  showEnv
186  showLocales
187