· 7 years ago · Dec 18, 2018, 07:58 PM
1{-# LANGUAGE
2 DeriveGeneric, GADTs, OverloadedStrings, FlexibleContexts, FlexibleInstances, TypeFamilies, TypeApplications, StandaloneDeriving, TypeSynonymInstances, MultiParamTypeClasses, TemplateHaskell #-}
3
4module Main where
5
6import Prelude hiding (Filepath)
7import System.FilePath
8import System.Directory
9import Options.Applicative
10import Control.Lens hiding (argument)
11import Database.Beam
12import Database.Beam.Sqlite
13import Database.SQLite.Simple hiding (withConnection)
14import Database.SQLite.SimpleErrors.Types (SQLiteResponse)
15import Database.SQLite.SimpleErrors
16import Data.Text (Text, pack)
17import Control.Monad.Reader
18import Control.Monad.Except
19import Control.Monad.Error.Hoist
20import Control.Error
21import Control.Exception
22import Control.Exception.Lens
23import Data.Foldable
24
25
26
27-- | Create datatype for the path we want to save in the database. When we save a path we give it a name, and a directory
28-- | Beam also uses this datatype to talk to the database. The naming convention is, as far as I can see that it converts
29-- | the camelCase to column names, by taking the capitalized parts and doing toLower and then adding an underscore.
30-- | So 'pathPathName' becomes 'path_name' in the database.
31data PathT f = Path
32 { _pathPathName :: C f Text
33 , _pathPathDir :: C f Text
34 } deriving Generic
35
36makeLenses ''PathT
37
38-- | Here we create a new type we can use as a User in our regular Haskell program.
39-- | We also create a 'PathId' we can use in our regular program as the primary key in the table.
40type Path = PathT Identity
41type PathId = PrimaryKey PathT Identity
42
43deriving instance Show Path
44deriving instance Eq Path
45
46-- | We have have an instane of 'Beamable' to be able to talk to the database provided.
47-- | We also define the primary key here.
48instance Beamable PathT
49instance Table PathT where
50 data PrimaryKey PathT f = PathId (C f Text) deriving Generic
51 primaryKey = PathId . _pathPathName
52
53instance Beamable (PrimaryKey PathT)
54
55-- | We define the table in the database, in terms of the 'PathT' datatype, that will make up the columns.
56data TransportDb f = TransportDb
57 { _transportPathList :: f (TableEntity PathT) }
58 deriving Generic
59
60makeLenses ''TransportDb
61
62instance Database be TransportDb
63
64-- | This is a way to initiate the database, as far as I understand.
65transportDb :: DatabaseSettings be TransportDb
66transportDb = defaultDbSettings
67
68-- | We create the DbConfig datatype, to be able to hold a connection in the environment.
69data DbConfig = DbConfig
70 { _dbConf :: Connection
71 , _dbPath :: FilePath
72 }
73
74makeClassy ''DbConfig
75
76data DbError = DbErrorCode SQLiteResponse | UnknownError
77 deriving Show
78
79makeClassyPrisms ''DbError
80
81data AppError = AppDbError DbError | GenerelError
82 deriving Show
83
84makeClassyPrisms ''AppError
85
86instance AsDbError AppError where
87 _DbError = _AppDbError . _DbError
88 _UnknownError = _AppDbError . _UnknownError
89
90appErrorString :: AppError -> String
91appErrorString (AppDbError db) = dbErrorString db
92appErrorString GenerelError = "there was an unknown error"
93
94dbErrorString :: DbError -> String
95dbErrorString (DbErrorCode c) = "There was a problem with the database: " <> show c
96
97successString :: a -> String
98successString a = "success"
99
100initDb :: Script DbConfig
101initDb = do
102 path <- getDbPath
103 conn <- scriptIO $ open path
104 pure $ DbConfig conn path
105
106getDbPath :: Script FilePath
107getDbPath = do
108 home <- scriptIO $ getHomeDirectory
109 pure $ (home </> (".transport.db" :: FilePath))
110
111
112
113
114
115
116-- | PARSER STUFF
117
118data Command = CommandList
119 | CommandAdd { addName :: String
120 , addPath :: FilePath }
121 | CommandRemove { removeName :: String }
122 | CommandTP { tpName :: String }
123 deriving Show
124
125transportDesc :: String
126transportDesc = "use transport to setup transport paths, and move to them at will"
127
128
129transportHeader :: String
130transportHeader = "Transport: move quickly around your filesystem"
131
132parseCommand :: Parser Command
133parseCommand = subparser $
134 (command "add" (info (helper <*> parseAddCommand) (fullDesc <> progDesc "add a transport path"))) <>
135 (command "list" (info (helper <*> parseListCommand) (fullDesc <> progDesc "list all transport paths"))) <>
136 (command "remove" (info (helper <*> parseRemoveCommand) (fullDesc <> progDesc "remove a transport path"))) <>
137 (command "tp" (info (helper <*> parseTPCommand) (fullDesc <> progDesc "transport to existing path")))
138
139parseListCommand :: Parser Command
140parseListCommand = pure (CommandList)
141
142parseAddCommand :: Parser Command
143parseAddCommand = CommandAdd <$> nameParser <*> pathParser
144
145parseRemoveCommand :: Parser Command
146parseRemoveCommand = CommandRemove <$> nameParser
147
148parseTPCommand :: Parser Command
149parseTPCommand = CommandTP <$> nameParser
150
151nameParser :: Parser String
152nameParser = argument str (metavar "NAME" <> help "name of the transport path you want to save")
153
154pathParser :: Parser FilePath
155pathParser = argument (str >>= validatePath) (value "./" <> metavar "PATH" <> help ("path you want to save. " <>
156 "default: current working dir"))
157
158validatePath :: String -> ReadM FilePath
159validatePath path = do
160 if isValid path
161 then pure path
162 else readerError $ "invalid path: " <> show path
163
164
165-- | UTIL STUFF
166
167wrapException :: (Exception e, MonadError e' m, MonadIO m, Applicative m) => (e -> e') -> IO a -> m a
168wrapException f a = do
169 liftIO (catch (fmap Right a) (pure . Left . f)) <%!?> id
170
171wrapExceptions :: (MonadError e m, MonadIO m, Applicative m) => IO a -> [Handler e] -> m a
172wrapExceptions a hs = liftIO (catches (fmap Right a) handlers) <%!?> id
173 where handlers = fmap (fmap Left) hs
174
175rethrowDbError :: (MonadError e m, AsDbError e) => DatabaseResponse a -> m a
176rethrowDbError x = case x of
177 Left x -> throwError $ _DbErrorCode # x
178 Right x -> pure x
179
180-- | DATABASE STUFF
181
182_SQLiteResponse :: Prism' SomeException SQLiteResponse
183_SQLiteResponse = exception
184
185withConnection' :: (MonadError e m, MonadReader r m, MonadIO m, HasDbConfig r, AsDbError e) => (Connection -> IO a) -> m a
186withConnection' f = do
187 c <- view dbConf
188 (liftIO (f c)) >>= rethrowDbError
189
190withConnection :: (MonadError e m, MonadReader r m, MonadIO m, HasDbConfig r, AsDbError e) => (Connection -> IO a) -> m a
191withConnection f = do
192 c <- view dbConf
193 wrapExceptions (f c)
194 [ handler _SQLiteResponse (pure . (_DbErrorCode #)) ]
195
196selectAllPathsDebug :: (MonadError e m, MonadReader r m, MonadIO m, HasDbConfig r, AsDbError e) => m (DatabaseResponse ())
197selectAllPathsDebug = withConnection' (\c ->
198 runDBAction . runBeamSqliteDebug putStrLn c $ do
199 paths <- runSelectReturningList $ select (all_ (transportDb ^. transportPathList))
200 traverse_ (liftIO . putStrLn . show) paths)
201
202
203selectAllPaths :: (MonadReader r m, MonadIO m, HasDbConfig r) => m [Path]
204selectAllPaths = do
205 conf <- view dbConf
206 liftIO . runBeamSqlite conf $ do
207 paths <- runSelectReturningList $ select (all_ (transportDb ^. transportPathList))
208 pure paths
209
210selectWhereDebug :: (MonadReader r m, MonadIO m, HasDbConfig r) => Text -> m ()
211selectWhereDebug name = do
212 conf <- view dbConf
213 liftIO . runBeamSqliteDebug putStrLn conf $ do
214 user <- runSelectReturningOne $ lookup_ (transportDb ^. transportPathList) (PathId name)
215 case user of
216 Nothing -> liftIO . putStrLn $ "no such user"
217 Just x -> (liftIO . putStrLn . show) x
218
219selectWhere :: (MonadReader r m, MonadIO m, HasDbConfig r) => Text -> m (Maybe Path)
220selectWhere name = do
221 conf <- view dbConf
222 liftIO . runBeamSqlite conf $ do
223 user <- runSelectReturningOne $ lookup_ (transportDb ^. transportPathList) (PathId name)
224 pure user
225
226insertTestPaths :: (MonadError e m, MonadReader r m, MonadIO m, HasDbConfig r, AsDbError e) => m (DatabaseResponse ())
227insertTestPaths = withConnection' (\c ->
228 runDBAction . runBeamSqliteDebug putStrLn c $ runInsert $
229 insert (transportDb ^. transportPathList) $
230 insertValues [ Path "peter" "~/peter"
231 , Path "johanna" "~/"])
232
233insertPath :: (MonadReader r m, MonadIO m, HasDbConfig r) => Text -> Text -> m ()
234insertPath name dir = do
235 conf <- view dbConf
236 liftIO . runBeamSqlite conf $ runInsert $
237 insert (transportDb ^. transportPathList) $
238 insertValues [ Path name dir ]
239
240deletePathDebug :: (MonadReader r m, MonadIO m, HasDbConfig r) => Text -> m ()
241deletePathDebug name = do
242 conf <- view dbConf
243 liftIO . runBeamSqlite conf $ runDelete $
244 delete (transportDb ^. transportPathList) (\path -> path ^. pathPathName ==. (val_ name))
245
246
247
248-- | APP STUFF
249
250runApp :: DbConfig -> ExceptT AppError (ReaderT DbConfig IO) a -> IO (Either AppError a)
251runApp config = flip runReaderT config . runExceptT
252
253--main :: IO ()
254--main = do
255 --c <- runScript $ initDb
256 ---- execute_ (c ^. dbConf) "CREATE TABLE IF NOT EXISTS path_list (path_name VARCHAR NOT NULL, path_dir VARCHAR NOT NULL, PRIMARY KEY( path_name ))
257 --e <- runApp c selectAllPathsDebug''
258 --putStrLn . either appErrorString successString $ e
259
260main :: IO ()
261main = do
262 c <- runScript $ initDb
263 -- execute_ (c ^. dbConf) "CREATE TABLE IF NOT EXISTS path_list (path_name VARCHAR NOT NULL, path_dir VARCHAR NOT NULL, PRIMARY KEY( path_name ))
264 e <- runApp c insertTestPaths
265 case e of
266 Left x -> putStrLn $ appErrorString x
267 Right x -> putStrLn $ show x