Allow custom siteurl/home for locopy

1 files changed, 71 insertions, 0 deletions

diff --git a/locopy/Locopy/Wordpress.hs b/locopy/Locopy/Wordpress.hs
new file mode 100644
index 0000000..0587624
--- /dev/null
+++ b/locopy/Locopy/Wordpress.hs
@@ -0,0 +1,71 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+module Locopy.Wordpress
+    ( wordpress
+    ) where
+
+import qualified Data.Aeson as Aeson
+import Data.Aeson.TH (deriveJSON)
+import Data.Word (Word16)
+import Data.Text (StrictText)
+import qualified Data.Text as StrictText
+import qualified Data.Text.Read as StrictText
+import Locopy.CommandLine (Wordpress(..))
+import System.Directory
+    ( withCurrentDirectory
+    , getCurrentDirectory
+    )
+import System.FilePath ((</>))
+import System.Process (readProcess)
+import Data.String (IsString(..))
+import Control.Monad (void)
+
+data WpConfig = WpConfig
+    { dbName :: StrictText
+    , dbUser :: StrictText
+    , dbPassword :: StrictText
+    , dbHost :: StrictText
+    , tablePrefix :: StrictText
+    } deriving (Eq, Show)
+
+$(deriveJSON Aeson.defaultOptions 'WpConfig)
+
+readConfiguration :: FilePath -> IO WpConfig
+readConfiguration root = do
+    currentDirectory <- getCurrentDirectory
+    let wpSettingsPath = currentDirectory </> "locopy" </> "wp-settings.php"
+    withCurrentDirectory root (readProcess "php" [wpSettingsPath] "")
+        >>= Aeson.throwDecodeStrict . fromString
+
+updateOptions :: String -> WpConfig -> IO ()
+updateOptions siteurl WpConfig{..} =
+    let query
+            = "UPDATE "
+            <> tablePrefix
+            <> "options SET option_value = '"
+            <> StrictText.pack siteurl
+            <> "' WHERE option_name IN ('siteurl', 'home')"
+     in void $ readProcess "mariadb"
+        ([ "--host=" <> StrictText.unpack dbHost
+        , "--user=" <> StrictText.unpack dbUser
+        , StrictText.unpack dbName
+        ] <> hostOptions (StrictText.splitOn ":" dbHost)) (StrictText.unpack query)
+  where
+    hostOptions [onlyHost] = ["--host=" <> StrictText.unpack onlyHost]
+    hostOptions [host, port]
+        | Right (portNumber, "") <- StrictText.decimal port =
+            [ "--host=" <> StrictText.unpack host
+            , "--port=" <> show (portNumber :: Word16)
+            ]
+        | otherwise =
+            [ "--host=" <> StrictText.unpack host
+            , "--socket=" <> StrictText.unpack port
+            ]
+    hostOptions _ = []
+
+wordpress :: Wordpress -> IO ()
+wordpress Wordpress{..}
+    = readConfiguration root
+    >>= updateOptions siteurl