From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 19 Feb 2019 09:31:59 +0000 (+0100)
Subject: Initial commit
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=5e153e87723ea5f9e4916a734173bee55571fde9;p=cleanm.git

Initial commit
---

5e153e87723ea5f9e4916a734173bee55571fde9
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..58df8c9
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+a.out
+Clean System Files
+*.json
diff --git a/flac.dcl b/flac.dcl
new file mode 100644
index 0000000..fb9f6c5
--- /dev/null
+++ b/flac.dcl
@@ -0,0 +1,6 @@
+definition module flac
+
+from System.FilePath import :: FilePath
+from Data.Error import :: MaybeError, :: MaybeErrorString
+
+getTags :: FilePath !*World -> *(MaybeErrorString [(String, String)], !*World)
diff --git a/flac.icl b/flac.icl
new file mode 100644
index 0000000..b45783c
--- /dev/null
+++ b/flac.icl
@@ -0,0 +1,52 @@
+implementation module flac
+
+import StdEnv
+
+import Data.Error
+import Data.Func
+import Control.Monad => qualified join
+import System.FilePath
+import System._Pointer
+import System._Posix
+import Text
+
+import StdDebug
+
+NUM_COMMENT_OFFSET :== 32
+COMMENTS_OFFSET :== 40
+COMMENT_SIZE :== 16
+
+getTags :: FilePath !*World -> *(MaybeErrorString [(String, String)], !*World)
+getTags fp w
+	#! (mdp, w) = mallocSt 8 w
+	#! (ok, w) = FLAC__metadata_get_tags (packString fp) mdp w
+	| not ok
+		#! w = freeSt mdp w
+		= (Error "Error getting tags", w)
+	#! md = derefInt mdp
+	#! num_comments = readInt md NUM_COMMENT_OFFSET
+	#! comments = readInt md COMMENTS_OFFSET
+	#! comments = mapM (makeComment o derefString)
+		[readInt comments (COMMENT_SIZE*i+8)\\i<-[0..num_comments-1]]
+	#! w = FLAC__metadata_object_delete md w
+	#! w = freeSt mdp w
+	= (comments, w)
+where
+	makeComment :: !String -> MaybeErrorString (String, String)
+	makeComment s = case indexOf "=" s of
+		-1 = Error "No = in the tag"
+		i = Ok (s % (0, i-1), s % (i+1, size s))
+
+FLAC__metadata_get_tags :: !String !Pointer !*env -> (!Bool, !*env)
+FLAC__metadata_get_tags _ _ _ = code {
+	ccall FLAC__metadata_get_tags "sp:I:A"
+}
+
+FLAC__metadata_object_delete :: !Pointer !*env -> *env
+FLAC__metadata_object_delete _ _ = code {
+	ccall FLAC__metadata_object_delete "p:V:A"
+}
+
+Start w = getTags
+	"/mnt/data/music/Ahab/The Divinity of Oceans/01 Yet Another Raft of the Medusa (Pollard's Weakness).flac"
+	w
diff --git a/index.dcl b/index.dcl
new file mode 100644
index 0000000..c801bb1
--- /dev/null
+++ b/index.dcl
@@ -0,0 +1,3 @@
+definition module index
+
+:: MusicDB
diff --git a/index.icl b/index.icl
new file mode 100644
index 0000000..373ed82
--- /dev/null
+++ b/index.icl
@@ -0,0 +1,45 @@
+implementation module index
+
+import StdEnv
+import Data.Maybe
+import Data.Error
+import System.File
+import System.Directory
+import Text.GenJSON
+import Data.Tree
+
+derive JSONEncode RTree, FileInfo, Tm, MaybeError
+derive JSONDecode RTree, FileInfo, Tm, MaybeError
+
+:: MusicDB :== RTree MusicEntry
+:: MusicEntry =
+	{ fe_filepath   :: !FilePath
+	, fe_fileinfo   :: !MaybeOSError FileInfo
+	, fe_musicentry :: [!Tag!]
+	}
+:: Tag =
+	{ tag_key   :: !String
+	, tag_value :: !String
+	}
+
+index :: MusicDB (RTree (FilePath, MaybeOSError FileInfo)) *World -> *(MusicDB, *World)
+index (RNode mn mcs) (RNode (fp, mfi) fcs) w = (RNode mn mcs, w)
+
+dbfile = "db.json"
+root = "/mnt/data/music"
+
+writeDB db w
+	# (ok, f, w) = fopen dbfile FWriteData w
+	| not ok = abort "Cannot open file\n"
+	# (ok, w) = fclose (f <<< toJSON db) w
+	| not ok = abort "Cannot close file\n"
+	= w
+
+Start w
+	# (mfi, w) = getFileInfo root w
+	| isError mfi = abort "Cannot open root\n"
+	# (Ok fi) = mfi
+	| not fi.directory = abort "Root is not a directory\n"
+	# (tree, w) = readDirectoryTree root Nothing w
+	# (db, w) = index (RNode {fe_filepath=root,fe_fileinfo=mfi,fe_musicentry=[!!]} []) tree w
+	= writeDB tree w